DeltaStreams: DeltaStreams-Installer-gk.4.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of DeltaStreams-Installer was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-Installer-gk.4.mcz
==================== Summary ====================
Name: DeltaStreams-Installer-gk.4
Author: gk
Time: 4 September 2009, 12:30:53 pm
UUID: 8eb69339-f00a-435a-a7d8-12e78d2e969e
Ancestors: DeltaStreams-Installer-gk.3
Removed deprecated.
=============== Diff against DeltaStreams-Installer-gk.3 ===============
Item was changed:
----- Method: DSInstaller class>>install (in category 'as yet unclassified') -----
install
"DSInstaller install"
Installer squeaksource
project: 'SystemEditor'; "Main mechanism used for actual Delta apply"
install: 'SystemEditor-Core';
install: 'SystemEditor-Squeak';
install: 'SystemEditor-Traits';
install: 'SystemEditor-Tests';
install: 'SystemEditorBrowser';
project: 'Tirade'; "This is used for serialization/deserialization - not essential unless you need to store Deltas"
install: 'Tirade';
install: 'Tirade-Tests';
project: 'DeltaStreams';
install: 'System'; "Fixes for change notifications"
install: 'Traits'; "Fixes for change notifications"
install: 'Monticello'; "Fixes for change notifications"
install: 'DeltaStreams-Model'; "Domain model of Deltas"
install: 'DeltaStreams-Logging'; "Extensions for hooking into SystemChangeNotification in Squeak"
install: 'DeltaStreams-Tirade'; "Support for filing out/in Deltas in Tirade syntax"
+ install: 'DeltaStreams-Tests'. "All the tests for all packages"
- install: 'DeltaStreams-Tests'; "All the tests for all packages"
- install: 'DeltaStreams-Deprecated'. "Old stuff being thrown away eventually"
self inform: 'DeltaStreams successfully installed!! Time to put your helmet on.'
!
1
0
04 Sep '09
A new version of Traits was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/Traits-gk.234.mcz
==================== Summary ====================
Name: Traits-gk.234
Author: gk
Time: 4 September 2009, 11:56:56 am
UUID: c325922f-e4f5-4486-8305-e70764d5f455
Ancestors: Traits-ar.233, Traits-gk.230
Merge with trunk.
=============== Diff against Traits-gk.230 ===============
Item was changed:
----- 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.
- localSelectors _ aSet.
- methodDict _ aMethodDict.
- traitComposition _ aComposition.
self organization: aClassOrganization
!
Item was changed:
----- Method: TraitAlias>>allAliasesDict (in category 'enquiries') -----
allAliasesDict
| dict |
+ dict := super allAliasesDict.
- dict _ super allAliasesDict.
self aliases do: [:assoc |
dict at: assoc key put: assoc value].
^dict!
Item was changed:
----- Method: TraitComposition>>methodDescriptionForSelector: (in category 'enquiries') -----
methodDescriptionForSelector: aSymbol
"Return a TraitMethodDescription for the selector aSymbol."
| description |
+ description := TraitMethodDescription selector: aSymbol.
- description _ TraitMethodDescription selector: aSymbol.
self transformations do: [:each |
each collectMethodsFor: aSymbol into: description].
^description!
Item was changed:
----- Method: FixedIdentitySet>>destructiveAdd: (in category 'accessing') -----
destructiveAdd: anObject
| index old |
self isFull ifTrue: [^ false].
+ index := self indexOf: anObject.
+ old := self basicAt: index.
- index _ self indexOf: anObject.
- old _ self basicAt: index.
self basicAt: index put: anObject.
+ old ifNil: [tally := tally + 1].
- old ifNil: [tally _ tally + 1].
^ true!
Item was changed:
----- Method: Trait>>environment: (in category 'accessing') -----
environment: anObject
+ environment := anObject!
- environment _ anObject!
Item was changed:
----- Method: TraitBehavior>>basicLocalSelectors: (in category 'accessing method dictionary') -----
basicLocalSelectors: aSetOrNil
+ localSelectors := aSetOrNil!
- localSelectors _ aSetOrNil!
Item was changed:
----- 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 _ self allSuperclasses.
temp addFirst: self.
^ temp!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>findRootsAndRoutes (in category 'calculating') -----
findRootsAndRoutes
"Based on the
1. target classes (ones considered interesting by our clients) and the
2. modifiedBehaviors (ones we are told might have changed),
decide the
A. rootClasses (superclasses of target classes that include methods from modifiedBehaviors)
B. classesToUpdate (classes that may have been affected AND are on an inheritance path between a root class and a target class, will be updated by the algorithm. This includes the every target class that may have been affected).
C. mapping from root classes to its classesToUpdate."
| highestSuperclassOfCurrentTarget modifiedClasses |
classesToUpdate := IdentitySet new.
rootClasses := IdentitySet new.
modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet.
targetClasses do: [:currentTargetClass |
+ highestSuperclassOfCurrentTarget := nil.
- highestSuperclassOfCurrentTarget _ nil.
currentTargetClass withAllSuperclassesDo: [:sc |
(modifiedClasses includes: sc) ifTrue:
[highestSuperclassOfCurrentTarget := sc.
self noteRoot: sc possiblyAffected: currentTargetClass]].
highestSuperclassOfCurrentTarget ifNotNilDo: [:highestRoot |
self addUpdatePathTo: currentTargetClass from: highestRoot]]!
Item was changed:
----- 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.
- localSelectors _ aSet.
- methodDict _ aMethodDict.
- traitComposition _ aComposition.
self organization: aClassOrganization!
Item was changed:
----- Method: SendInfo>>prepareState (in category 'initialization') -----
prepareState
| nrsArray |
self newEmptyStack.
+ savedStacks := QuickIntegerDictionary new: (sender endPC).
+ isStartOfBlock := false.
+ nrsArray := self class neverRequiredSelectors.
- 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.!
- nr1 _ nrsArray at: 1.
- nr2 _ nrsArray at: 2.
- nr3 _ nrsArray at: 3.
- nr4 _ nrsArray at: 4.
- nr5 _ nrsArray at: 5.!
Item was changed:
----- Method: FixedIdentitySet>>do: (in category 'enumerating') -----
do: aBlock
| obj count |
+ count := 0.
- count _ 0.
1 to: self basicSize do: [:index |
count >= tally ifTrue: [^ self].
+ obj := self basicAt: index.
+ obj ifNotNil: [count := count + 1. aBlock value: obj].
- obj _ self basicAt: index.
- obj ifNotNil: [count _ count + 1. aBlock value: obj].
].
!
Item was changed:
----- Method: TraitMethodDescription>>generateTemplateMethodWithMarker:forArgs:binary: (in category 'private') -----
generateTemplateMethodWithMarker: aSymbol forArgs: aNumber binary: aBoolean
| source node |
+ source := String streamContents: [:stream |
- 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
- node _ self class compilerClass new
compile: source
in: self class
notifying: nil
ifFail: [].
^node generate.!
Item was changed:
----- 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].
- 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!
Item was changed:
----- Method: FixedIdentitySet>>add: (in category 'accessing') -----
add: anObject
| index old |
self isFull ifTrue: [^ false].
+ index := self indexOf: anObject.
+ old := self basicAt: index.
- index _ self indexOf: anObject.
- old _ self basicAt: index.
old == anObject ifTrue: [^ true].
old ifNotNil: [^ false].
self basicAt: index put: anObject.
+ tally := tally + 1.
- tally _ tally + 1.
^ true!
Item was changed:
----- Method: TUpdateTraitsBehavior>>setTraitComposition: (in category 'traits') -----
setTraitComposition: aTraitComposition
| oldComposition |
(self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self].
aTraitComposition assertValidUser: self.
+ oldComposition := self traitComposition.
- oldComposition _ self traitComposition.
self traitComposition: aTraitComposition.
self applyChangesOfNewTraitCompositionReplacing: oldComposition.
oldComposition traits do: [:each | each removeUser: self].
aTraitComposition traits do: [:each | each addUser: self]!
Item was changed:
----- 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.
- oldCategory _ self organization categoryOfElement: each.
- newCategory _ (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory.
self noteRecategorizedSelector: each from: oldCategory to: newCategory]!
Item was changed:
----- Method: SendCaches>>addSuperSender:of: (in category 'updates') -----
addSuperSender: sendingSelector of: sentSelector
| senders |
+ senders := superSenders at: sentSelector ifAbsent: [#()].
- senders _ superSenders at: sentSelector ifAbsent: [#()].
superSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was changed:
----- 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
- 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.!
Item was changed:
----- Method: LocatedMethodTest>>testEquality (in category 'running') -----
testEquality
| locatedMethod1 locatedMethod2 |
+ locatedMethod1 := LocatedMethod location: self class selector: #testEquality.
+ locatedMethod2 := LocatedMethod location: self class selector: #testEquality.
- locatedMethod1 _ LocatedMethod location: self class selector: #testEquality.
- locatedMethod2 _ LocatedMethod location: self class selector: #testEquality.
self assert: locatedMethod1 = locatedMethod2.
self assert: locatedMethod1 hash = locatedMethod2 hash!
Item was changed:
----- Method: TFileInOutDescription>>fileOutChangedMessages:on:moveSource:toFile: (in category 'fileIn/Out') -----
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex
"File a description of the messages of this class that have been
changed (i.e., are entered into the argument, aSet) onto aFileStream. If
moveSource, is true, then set the method source pointer to the new file position.
Note when this method is called with moveSource=true, it is condensing the
.changes file, and should only write a preamble for every method."
| org sels |
+ (org := self organization) categories do:
- (org _ self organization) categories do:
[:cat |
+ sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
- sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
sels do:
[:sel | self printMethodChunk: sel withPreamble: true on: aFileStream
moveSource: moveSource toFile: fileIndex]]!
Item was changed:
----- Method: TraitMethodDescriptionTest>>testInitialize (in category 'running') -----
testInitialize
| empty |
+ empty := TraitMethodDescription new.
- empty _ TraitMethodDescription new.
self assert: empty isEmpty.
self deny: empty isConflict.
self deny: empty isProvided.
self deny: empty isRequired!
Item was changed:
----- 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 _ 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.
!
Item was changed:
----- 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 :=
- 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!
Item was changed:
----- Method: TraitFileOutTest>>setUp (in category 'running') -----
setUp
super setUp.
SystemOrganization addCategory: self categoryName.
+ td := self createTraitNamed: #TD uses: {}.
- td _ self createTraitNamed: #TD uses: {}.
td compile: 'd' classified: #cat1.
+ tc := self createTraitNamed: #TC uses: td.
- tc _ self createTraitNamed: #TC uses: td.
tc compile: 'c' classified: #cat1.
+ tb := self createTraitNamed: #TB uses: td.
- tb _ self createTraitNamed: #TB uses: td.
tb compile: 'b' classified: #cat1.
+ ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}.
- ta _ self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}.
ta compile: 'a' classified: #cat1.
+ ca := self createClassNamed: #CA superclass: Object uses: {}.
- ca _ self createClassNamed: #CA superclass: Object uses: {}.
ca compile: 'ca' classified: #cat1.
+ cb := self createClassNamed: #CB superclass: ca uses: ta.
- 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: ''.!
Item was changed:
----- 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.
- destination _ self pc + distance.
"remove the condition from the stack."
self pop.
savedStacks at: destination put: stack copy.
!
Item was changed:
----- Method: SendInfo>>mergeStacks (in category 'stack manipulation') -----
mergeStacks
| otherStack |
+ otherStack := savedStacks at: pc.
- 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 ].
- ^ 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]]!
Item was changed:
----- Method: ClassTrait>>initializeFrom: (in category 'initialize') -----
initializeFrom: anotherClassTrait
+ traitComposition := self traitComposition copyTraitExpression.
+ methodDict := self methodDict copy.
+ localSelectors := self localSelectors copy.
+ organization := self organization copy.!
- traitComposition _ self traitComposition copyTraitExpression.
- methodDict _ self methodDict copy.
- localSelectors _ self localSelectors copy.
- organization _ self organization copy.!
Item was changed:
----- Method: TraitCompositionTest>>testEmptyTrait (in category 'testing-basic') -----
testEmptyTrait
| composition |
+ composition := {} asTraitComposition.
- composition _ {} asTraitComposition.
self assert: (composition isKindOf: TraitComposition).
self assert: composition transformations isEmpty.
self assert: composition traits isEmpty!
Item was changed:
----- Method: TraitComposition>>copyWithoutAlias:of: (in category 'copying') -----
copyWithoutAlias: aSymbol of: aTrait
| composition transformation |
+ composition := self copyTraitExpression.
+ transformation := (composition transformationOfTrait: aTrait).
- composition _ self copyTraitExpression.
- transformation _ (composition transformationOfTrait: aTrait).
^composition
remove: transformation;
add: (transformation removeAlias: aSymbol);
normalizeTransformations;
yourself!
Item was changed:
----- Method: TTraitsCategorisingDescription>>applyChangesOfNewTraitCompositionReplacing: (in category 'organization updating') -----
applyChangesOfNewTraitCompositionReplacing: oldComposition
| changedSelectors |
+ changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition.
- changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition.
^ changedSelectors.!
Item was changed:
----- Method: TraitComposition>>copyWithExclusionOf:to: (in category 'copying') -----
copyWithExclusionOf: aSymbol to: aTrait
| composition transformation |
+ composition := self copyTraitExpression.
+ transformation := (composition transformationOfTrait: aTrait).
- composition _ self copyTraitExpression.
- transformation _ (composition transformationOfTrait: aTrait).
^composition
remove: transformation;
add: (transformation addExclusionOf: aSymbol);
yourself!
Item was changed:
----- Method: Trait class>>named:uses:category: (in category 'instance creation') -----
named: aSymbol uses: aTraitCompositionOrCollection category: aString
| env |
+ env := self environment.
- env _ self environment.
^self
named: aSymbol
uses: aTraitCompositionOrCollection
category: aString
env: env!
Item was changed:
----- 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)
- methodDescription _ (self methodDescriptionsForSelector: aSymbol)
detect: [:each | each selector = aSymbol].
^methodDescription isAliasSelector!
Item was changed:
----- 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.
- 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!
Item was changed:
----- Method: TraitBehavior>>initialize (in category 'initialize-release') -----
initialize
self methodDict: MethodDictionary new.
self traitComposition: nil.
+ users := IdentitySet new.!
- users _ IdentitySet new.!
Item was changed:
----- 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.
- 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.!
Item was changed:
----- Method: QuickStack>>setTop: (in category 'private') -----
setTop: t
+ top := t!
- top _ t!
Item was changed:
----- Method: SendCaches>>addSelfSender:of: (in category 'updates') -----
addSelfSender: sendingSelector of: sentSelector
| senders |
+ senders := selfSenders at: sentSelector ifAbsent: [#()].
- senders _ selfSenders at: sentSelector ifAbsent: [#()].
selfSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was changed:
----- 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: ' ,
- ifTrue: [preamble _ self name , ' methodsFor: ' ,
(self organization categoryOfElement: selector) asString printString]
+ ifFalse: [preamble := ''].
+ method := self methodDict at: selector ifAbsent:
- 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])
- 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.
- [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.
- 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.
- [endPos _ outStream position.
method checkOKToAdd: endPos - newPos at: newPos.
method setSourcePosition: newPos inFile: fileIndex]].
preamble size > 0 ifTrue: [outStream nextChunkPut: ' '].
^ outStream cr!
Item was changed:
----- 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.
- 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.!
Item was changed:
----- 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)
- methodDescription _ (self methodDescriptionsForSelector: aSymbol)
detect: [:each | each selector = aSymbol].
^methodDescription isLocalAliasSelector!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>findOriginalSins (in category 'calculating') -----
findOriginalSins
| sinnedSelectors sinners checkedClasses |
+ checkedClasses := IdentitySet new.
- 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]]]]!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>initialize (in category 'calculating') -----
initialize
+ possiblyAffectedPerRoot := IdentityDictionary new.!
- possiblyAffectedPerRoot _ IdentityDictionary new.!
Item was changed:
----- Method: ClassTrait>>baseTrait: (in category 'accessing parallel hierarchy') -----
baseTrait: aTrait
self assert: aTrait isBaseTrait.
+ baseTrait := aTrait
- baseTrait _ aTrait
!
Item was changed:
----- 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 _ 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: "
!
Item was changed:
----- 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 _ self baseTrait users select: [:each | each isClassSide].
classSideUsersOfBaseTrait isEmpty ifFalse: [
+ message := String streamContents: [:stream |
- 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!
Item was changed:
----- 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 _ class sourceMethodAt: sel.
code == nil
ifFalse:
[cat == nil
+ ifTrue: [category := class organization categoryOfElement: sel]
+ ifFalse: [category := cat].
- 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]!
Item was changed:
----- 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].
- special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b |
- byte _ b].
^self whichSelectorsReferTo: literal special: special byte: byte
"Rectangle whichSelectorsReferTo: #+."!
Item was changed:
----- Method: Trait>>classTrait: (in category 'accessing parallel hierarchy') -----
classTrait: aTrait
"Assigns the class trait associated with the receiver."
self assert: aTrait isClassTrait.
+ classTrait := aTrait!
- classTrait _ aTrait!
Item was changed:
----- 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.
- aSymbol _ varName asSymbol.
"Look in declared environment."
+ binding := self environment bindingOf: aSymbol.
- binding _ self environment bindingOf: aSymbol.
^binding!
Item was changed:
----- Method: TAccessingTraitCompositionBehavior>>traitsProvidingSelector: (in category 'traits') -----
traitsProvidingSelector: aSymbol
| result |
+ result := OrderedCollection new.
- 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!
Item was changed:
----- Method: TCompilingBehavior>>spaceUsed (in category 'private') -----
spaceUsed
"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."
| space method |
+ space := 0.
- 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").
- 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)]]].
- (lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)].
- (lit isMemberOf: Float) ifTrue: [space _ space + 12].
- (lit isMemberOf: ByteString) ifTrue: [space _ space + (lit size + 6)].
- (lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)].
- (lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]].
^ space!
Item was changed:
----- Method: SendInfo class>>neverRequiredSelectors (in category 'accessing') -----
neverRequiredSelectors
| nrs |
+ nrs := Array new: 5.
- 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.
!
Item was changed:
----- Method: TUpdateTraitsBehavior>>applyChangesOfNewTraitCompositionReplacing: (in category 'traits') -----
applyChangesOfNewTraitCompositionReplacing: oldComposition
| changedSelectors |
+ changedSelectors := self traitComposition
- changedSelectors _ self traitComposition
changedSelectorsComparedTo: oldComposition.
changedSelectors isEmpty ifFalse: [
self noteChangedSelectors: changedSelectors].
self traitComposition isEmpty ifTrue: [
self purgeLocalSelectors].
^changedSelectors!
Item was changed:
----- Method: SendInfo>>addSuperSentSelector: (in category 'private') -----
addSuperSentSelector: aSymbol
+ superSentSelectors ifNil: [superSentSelectors := IdentitySet new].
- superSentSelectors ifNil: [superSentSelectors _ IdentitySet new].
superSentSelectors add: aSymbol.!
Item was changed:
----- Method: TraitMethodDescription>>effectiveMethod (in category 'accessing') -----
effectiveMethod
"Return the effective compiled method of this method description."
| locatedMethod method |
+ method := self providedMethod.
- method _ self providedMethod.
method isNil ifFalse: [^ method].
+ method := self conflictMethod.
- method _ self conflictMethod.
method isNil ifFalse: [^ method].
^ self requiredMethod.!
Item was added:
+ ----- Method: SendInfo>>pushNewArrayOfSize: (in category 'instruction decoding') -----
+ pushNewArrayOfSize: arraySize
+ self push: #stuff!
Item was changed:
----- Method: SendInfo>>collectSends (in category 'initialization') -----
collectSends
| end |
+ end := self method endPC.
- end _ self method endPC.
[pc <= end]
whileTrue: [self interpretNextInstructionFor: self]!
Item was changed:
----- 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.
- 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.!
Item was changed:
----- Method: TraitAlias>>aliases: (in category 'accessing') -----
aliases: anArrayOfAssociations
| newNames |
+ newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet.
- 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!
- aliases _ anArrayOfAssociations!
Item was changed:
----- 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 _ self allSelectors asIdentitySet.
- otherSelectors _ aTraitTransformation allSelectors asIdentitySet.
- changedSelectors _ IdentitySet withAll: (
(selectors difference: otherSelectors) union: (otherSelectors difference: selectors)).
+ aliases := self allAliasesDict.
+ otherAliases := aTraitTransformation allAliasesDict.
- 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.!
Item was changed:
----- Method: TAccessingMethodDictDescription>>addSelector:withMethod:notifying: (in category 'accessing method dictionary') -----
addSelector: selector withMethod: compiledMethod notifying: requestor
| priorMethodOrNil |
+ priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil].
- 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].!
Item was changed:
----- 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
- 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
!
Item was changed:
----- 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.
- categoryName _ aString asSymbol.
(self organization listAtCategoryNamed: categoryName) do:
[:sel | self removeSelector: sel].
self organization removeCategory: categoryName!
Item was changed:
----- 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 _ self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil.
changedCategories do: [:each |
(self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]!
Item was changed:
----- 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 _ self locatedMethods anyOne.
(locatedMethod selector ~= self selector) or: [
locatedMethod location isAliasSelector: self selector]]!
Item was changed:
----- 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].
- 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!
Item was changed:
----- Method: TTraitsCategorisingDescription>>updateOrganizationSelector:oldCategory:newCategory: (in category 'organization updating') -----
updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil
| currentCategory effectiveCategory sel changedCategories composition |
+ changedCategories := IdentitySet new.
- changedCategories _ IdentitySet new.
composition := self hasTraitComposition
ifTrue: [self traitComposition]
ifFalse: [TraitComposition new].
(composition methodDescriptionsForSelector: aSymbol) do: [:each |
+ sel := each selector.
- sel _ each selector.
(self includesLocalSelector: sel) ifFalse: [
+ currentCategory := self organization categoryOfElement: sel.
+ effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil.
- currentCategory _ self organization categoryOfElement: sel.
- effectiveCategory _ each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil.
effectiveCategory isNil ifTrue: [
currentCategory ifNotNil: [changedCategories add: currentCategory].
self organization removeElement: sel.
] ifFalse: [
((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [
currentCategory ifNotNil: [changedCategories add: currentCategory].
self organization
classify: sel
under: effectiveCategory
suppressIfDefault: false]]]].
^ changedCategories!
Item was changed:
----- Method: 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
- argumentNames _ self getArgumentNames.
- binary _ self isBinarySelector.
- numberOfArguments _ binary
ifTrue: [1]
ifFalse: [argumentNames size + 2].
+ templateMethod := self requiredMethodForArguments: numberOfArguments ifAbsentPut: [
- templateMethod _ self requiredMethodForArguments: numberOfArguments ifAbsentPut: [
self
generateTemplateMethodWithMarker: CompiledMethod implicitRequirementMarker
forArgs: argumentNames size
binary: binary].
^templateMethod copyWithTempNames: argumentNames
!
Item was changed:
----- Method: TraitMethodDescription>>providedLocatedMethod (in category 'accessing') -----
providedLocatedMethod
| locatedMethod |
+ locatedMethod := nil.
- locatedMethod _ nil.
self locatedMethods do: [:each |
each method isProvided ifTrue: [
locatedMethod isNil ifFalse: [^nil].
+ locatedMethod := each]].
- locatedMethod _ each]].
^locatedMethod!
Item was changed:
----- 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 _ self methodDescriptionForSelector: aSymbol.
(methodDescription isProvided not or: [methodDescription isConflict])
ifTrue: [^nil].
+ locatedMethod := methodDescription providedLocatedMethod.
- locatedMethod _ methodDescription providedLocatedMethod.
^locatedMethod location traitOrClassOfSelector: locatedMethod selector!
Item was changed:
----- Method: TraitMethodDescription>>initialize (in category 'initialize-release') -----
initialize
super initialize.
+ locatedMethods := Set new!
- locatedMethods _ Set new!
Item was changed:
----- 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.
- hash _ self species hash.
self size <= 10 ifTrue:
+ [self do: [:elem | hash := hash bitXor: elem hash]].
- [self do: [:elem | hash _ hash bitXor: elem hash]].
^hash bitXor: self size hash!
Item was changed:
----- Method: QuickStack>>copy (in category 'copying') -----
copy
"Answer a copy of a myself"
| newSize |
+ newSize := self basicSize.
- newSize _ self basicSize.
^ (self class new: newSize)
replaceFrom: 1
to: top
with: self
startingAt: 1;
setTop: top!
Item was changed:
----- 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 _ aTraitComposition traits select: [:each | each isBaseTrait].
baseTraits isEmpty ifFalse: [
+ notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]).
- notAddable _ (baseTraits reject: [:each | each classSide methodDict isEmpty]).
notAddable isEmpty ifFalse: [
+ message := String streamContents: [:stream |
- 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.)']!
Item was changed:
----- Method: TraitComposition>>transformations: (in category 'private') -----
transformations: aCollection
+ transformations := aCollection!
- transformations _ aCollection!
Item was changed:
----- Method: SendCaches>>addClassSender:of: (in category 'updates') -----
addClassSender: sendingSelector of: sentSelector
| senders |
+ senders := classSenders at: sentSelector ifAbsent: [#()].
- senders _ classSenders at: sentSelector ifAbsent: [#()].
classSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was changed:
----- Method: FixedIdentitySet>>select: (in category 'enumerating') -----
select: aBlock
| result |
+ result := self species new: self capacity.
- result _ self species new: self capacity.
self do: [:each | (aBlock value: each) ifTrue: [result add: each]].
^ result.!
Item was changed:
----- 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
- 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).
!
Item was changed:
----- 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.
- newlyInteresting _ classes copyWithoutAll: self classesOfInterest.
super noteInterestOf: client inAll: classes.
newlyInteresting do: [:cl | self newlyInteresting: cl]!
Item was changed:
----- Method: Behavior>>computeTranslationsAndUpdateUnreachableSet: (in category '*Traits-requires') -----
computeTranslationsAndUpdateUnreachableSet: unreachableCollection
"This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors."
| translations reachableSenders oldUnreachable |
+ oldUnreachable := unreachableCollection copy.
+ translations := IdentityDictionary new.
- 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 _ FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable.
reachableSenders isEmpty ifFalse: [
translations at: sent put: reachableSenders.
unreachableCollection remove: sent ifAbsent: [].
].
].
^ translations!
Item was changed:
----- Method: TraitBehavior>>traitComposition: (in category 'traits') -----
traitComposition: aTraitComposition
+ traitComposition := aTraitComposition!
- traitComposition _ aTraitComposition!
Item was changed:
----- Method: TUpdateTraitsBehavior>>updateMethodDictionarySelector: (in category 'traits') -----
updateMethodDictionarySelector: aSymbol
"A method with selector aSymbol in myself or my traitComposition has been changed.
Do the appropriate update to my methodDict (remove or update method) and
return all affected selectors of me so that my useres get notified."
| effectiveMethod modifiedSelectors descriptions selector |
+ modifiedSelectors := IdentitySet new.
+ descriptions := self hasTraitComposition
- modifiedSelectors _ IdentitySet new.
- descriptions _ self hasTraitComposition
ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ]
ifFalse: [ #() ].
descriptions do: [:methodDescription |
+ selector := methodDescription selector.
- selector _ methodDescription selector.
(self includesLocalSelector: selector) ifFalse: [
methodDescription isEmpty
ifTrue: [
self removeTraitSelector: selector.
modifiedSelectors add: selector]
ifFalse: [
+ effectiveMethod := methodDescription effectiveMethod.
- effectiveMethod _ methodDescription effectiveMethod.
(self compiledMethodAt: selector ifAbsent: [nil]) ~~ effectiveMethod ifTrue: [
self addTraitSelector: selector withMethod: effectiveMethod.
modifiedSelectors add: selector]]]].
^modifiedSelectors!
Item was changed:
----- Method: QuickStack>>becomeEmpty (in category 'accessing') -----
becomeEmpty
+ top := 0!
- top _ 0!
Item was changed:
----- 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.
- selectors _ IdentitySet with: aSymbol.
self transformations do: [:each |
selectors addAll: (each aliasesForSelector: aSymbol)].
+ collection := OrderedCollection new: selectors size.
- collection _ OrderedCollection new: selectors size.
selectors do: [:each |
collection add: (self methodDescriptionForSelector: each)].
^collection!
Item was added:
+ ----- Method: TraitDescription>>variablesAndOffsetsDo: (in category 'as yet unclassified') -----
+ variablesAndOffsetsDo: aBinaryBlock
+ "This is the interface between the compiler and a class's instance or field names. The
+ class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed
+ by the instance variable name strings and their integer offsets (1-relative). The order is
+ important; names evaluated later will override the same names occurring earlier."
+
+ "Since Traits don't confer state there is nothing to do here."!
Item was added:
+ ----- Method: SendInfo>>pushConsArrayWithElements: (in category 'instruction decoding') -----
+ pushConsArrayWithElements: arraySize
+ self pop: arraySize.
+ self push: #stuff!
Item was changed:
----- Method: QuickStack>>addLast: (in category 'accessing') -----
addLast: aValue
top = self basicSize ifTrue: [self grow].
+ top := top + 1.
- top _ top + 1.
^ self at: top put: aValue!
Item was changed:
----- Method: TraitMethodDescription>>effectiveMethodCategoryCurrent:new: (in category 'accessing') -----
effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil
| isCurrent result cat size isConflict |
+ size := self size.
- size _ self size.
size = 0 ifTrue: [^ nil].
+ result := self locatedMethods anyOne category.
- result _ self locatedMethods anyOne category.
size = 1 ifTrue: [^ result].
+ isCurrent := currentCategoryOrNil isNil.
+ isConflict := false.
- isCurrent _ currentCategoryOrNil isNil.
- isConflict _ false.
self locatedMethods do: [:each |
+ cat := each category.
+ isCurrent := isCurrent or: [cat == currentCategoryOrNil].
+ isConflict := isConflict or: [cat ~~ result]].
- cat _ each category.
- isCurrent _ isCurrent or: [cat == currentCategoryOrNil].
- isConflict _ isConflict or: [cat ~~ result]].
isConflict ifFalse: [^ result].
(isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil].
^ ClassOrganizer ambiguous.!
Item was changed:
----- Method: 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.
- affectedSelectors _ IdentitySet new.
aCollection do: [:selector |
affectedSelectors addAll: (self updateMethodDictionarySelector: selector)].
self notifyUsersOfChangedSelectors: affectedSelectors.
^ affectedSelectors!
Item was changed:
----- Method: TPureBehavior>>standardMethodHeaderFor: (in category 'accessing method dictionary') -----
standardMethodHeaderFor: aSelector
| args |
+ args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString].
- 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:' '.
].
].
!
Item was changed:
----- Method: TCompilingDescription>>compile:classified:notifying: (in category 'compiling') -----
compile: text classified: category notifying: requestor
| stamp |
+ stamp := self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil].
- stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil].
^ self compile: text classified: category
withStamp: stamp notifying: requestor!
Item was changed:
----- 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!
- organization _ aClassOrg!
Item was changed:
----- 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 _ sss copyWithoutAll: (self allSelectors select: [:e | (self >> e) isProvided]).
- otherRequired _ self allSelectors select: [:e | (self >> e) isRequired].
^(selfSentNotProvided, otherRequired) asSet
!
Item was changed:
----- Method: QuickStack>>removeLast: (in category 'accessing') -----
removeLast: n
+ top := top - n!
- top _ top - n!
Item was changed:
----- Method: TraitComposition>>copyTraitExpression (in category 'copying') -----
copyTraitExpression
| newCopy |
+ newCopy := self shallowCopy.
- newCopy _ self shallowCopy.
newCopy transformations: (self transformations collect: [ : each | each copyTraitExpression ]).
^ newCopy
!
Item was changed:
----- 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
- aColl _ aName = ClassOrganizer allCategory
ifTrue: [self organization allMethodSelectors]
ifFalse: [self organization listAtCategoryNamed: aName].
^aColl asSet asSortedArray
"TileMorph allMethodsInCategory: #initialization"!
Item was changed:
----- 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 _ self aliasNamed: aSelector ifAbsent: [nil].
association notNil ifTrue: [
+ originalSelector := association value.
- originalSelector _ association value.
self subject
collectMethodsFor: originalSelector
into: methodDescription]!
Item was changed:
----- Method: Trait>>rename: (in category 'private') -----
rename: aString
"The new name of the receiver is the argument, aString."
| newName |
+ (newName := aString asSymbol) ~= self name
- (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!
- name _ newName!
Item was changed:
----- Method: TraitExclusion>>allSelectors (in category 'enquiries') -----
allSelectors
| selectors |
+ selectors := self subject allSelectors.
- selectors _ self subject allSelectors.
self exclusions do: [:each |
selectors remove: each ifAbsent: []].
^selectors!
Item was changed:
----- Method: TPureBehavior>>copy (in category 'copying') -----
copy
"Answer a copy of the receiver without a list of subclasses."
| myCopy |
+ myCopy := self shallowCopy.
- myCopy _ self shallowCopy.
^myCopy methodDictionary: self copyOfMethodDictionary!
Item was changed:
----- 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.
- isStartOfBlock _ true.
- numBlockArgs _ self pop.
^ self].
self pop: numArgs.
+ stackTop := self pop.
- 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])!
Item was changed:
----- 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])
- 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!
Item was changed:
----- Method: Trait>>initialize (in category 'initialize-release') -----
initialize
super initialize.
+ classTrait := ClassTrait for: self!
- classTrait _ ClassTrait for: self!
Item was changed:
----- Method: QuickStack>>grow (in category 'private') -----
grow
| newStack |
+ newStack := self class new: (self basicSize * 2).
- newStack _ self class new: (self basicSize * 2).
newStack replaceFrom: 1 to: top with: self startingAt: 1.
newStack setTop: top.
self becomeForward: newStack.
!
Item was changed:
----- 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.
- 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!
Item was changed:
----- 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.
- 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!
Item was changed:
----- 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
- size _ aCollection size = 1
ifTrue: [1]
ifFalse: [self sizeFor: aCollection].
^ (self new: size) addAll: aCollection notIn: notCollection; yourself!
Item was changed:
----- Method: LocatedMethod>>location:selector: (in category 'accessing') -----
location: aPureBehavior selector: aSymbol
+ location := aPureBehavior.
+ selector := aSymbol!
- location _ aPureBehavior.
- selector _ aSymbol!
Item was added:
+ ----- Method: SendInfo>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') -----
+ storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
+ "Simulate the action of bytecode that stores the top of the stack at
+ an offset in one of my local variables being used as a remote temp vector."!
Item was added:
+ ----- Method: SendInfo>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') -----
+ pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
+ "Simulate the action of bytecode that pushes the value at remoteTempIndex
+ in one of my local variables being used as a remote temp vector."
+ self push: #stuff!
Item was changed:
----- Method: SendInfo>>addSelfSentSelector: (in category 'private') -----
addSelfSentSelector: aSymbol
+ selfSentSelectors ifNil: [selfSentSelectors := IdentitySet new].
- selfSentSelectors ifNil: [selfSentSelectors _ IdentitySet new].
selfSentSelectors add: aSymbol.!
Item was changed:
----- 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
- systemCategory _ aString asSymbol.
- trait _ anEnvironment
at: aSymbol
ifAbsent: [nil].
+ oldTrait := trait copy.
+ trait := trait ifNil: [super new].
- 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!
Item was changed:
----- 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 _ 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.
!
Item was changed:
----- Method: FixedIdentitySet>>remove:ifAbsent: (in category 'accessing') -----
remove: anObject ifAbsent: aBlock
| index |
+ index := self indexOf: anObject.
- index _ self indexOf: anObject.
^ (self basicAt: index) == anObject
+ ifTrue: [self basicAt: index put: nil. tally := tally - 1. anObject]
- ifTrue: [self basicAt: index put: nil. tally _ tally - 1. anObject]
ifFalse: [aBlock value].!
Item was changed:
----- Method: TraitMethodDescription class>>initialize (in category 'class initialization') -----
initialize
" self initialize "
+ ConflictMethods := Array new: self maxArguments + 2.
+ RequiredMethods := Array new: self maxArguments + 2.!
- ConflictMethods _ Array new: self maxArguments + 2.
- RequiredMethods _ Array new: self maxArguments + 2.!
Item was changed:
----- Method: TimeMeasuringTest>>initialize (in category 'as yet unclassified') -----
initialize
+ shouldProfile := false.!
- shouldProfile _ false.!
Item was changed:
----- Method: TraitMethodDescription>>getArgumentNames (in category 'private') -----
getArgumentNames
| argumentNamesCollection names defaultName |
+ defaultName := 'arg'.
+ argumentNamesCollection := self locatedMethods
- defaultName _ 'arg'.
- argumentNamesCollection _ self locatedMethods
collect: [:each | each argumentNames ].
+ names := Array new: argumentNamesCollection anyOne size.
- 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
!
Item was changed:
----- Method: TimeMeasuringTest>>setToDebug (in category 'as yet unclassified') -----
setToDebug
+ shouldProfile := true
- shouldProfile _ true
!
Item was changed:
----- Method: Behavior>>translateReachableSelfSenders:translations: (in category '*Traits-requires') -----
translateReachableSelfSenders: senderCollection translations: translationDictionary
| result superSenders |
(translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection].
+ result := FixedIdentitySet new.
- result _ FixedIdentitySet new.
senderCollection do: [:s |
+ superSenders := translationDictionary at: s ifAbsent: [nil].
- superSenders _ translationDictionary at: s ifAbsent: [nil].
superSenders isNil
ifTrue: [result add: s]
ifFalse: [result addAll: superSenders].
result isFull ifTrue: [^ result].
].
^ result.!
Item was changed:
----- Method: Trait>>applyChangesOfNewTraitCompositionReplacing: (in category 'private') -----
applyChangesOfNewTraitCompositionReplacing: oldComposition
"Duplicated on Class"
| changedSelectors |
+ changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition.
- changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition.
self classSide
noteNewBaseTraitCompositionApplied: self traitComposition.
^ changedSelectors!
Item was changed:
----- Method: TCompilingBehavior>>selectorsWithArgs: (in category 'accessing method dictionary') -----
selectorsWithArgs: numberOfArgs
"Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this."
| list num |
+ list := OrderedCollection new.
- list _ OrderedCollection new.
self selectorsDo: [:aSel |
+ num := aSel count: [:char | char == $:].
+ num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]].
- num _ aSel count: [:char | char == $:].
- num = 0 ifTrue: [aSel last isLetter ifFalse: [num _ 1]].
num = numberOfArgs ifTrue: [list add: aSel]].
^ list!
Item was changed:
----- Method: ClassTrait>>uses: (in category 'composition') -----
uses: aTraitCompositionOrArray
| copyOfOldTrait newComposition |
+ copyOfOldTrait := self copy.
+ newComposition := aTraitCompositionOrArray asTraitComposition.
- copyOfOldTrait _ self copy.
- newComposition _ aTraitCompositionOrArray asTraitComposition.
self assertConsistantCompositionsForNew: newComposition.
self setTraitComposition: newComposition.
SystemChangeNotifier uniqueInstance
traitDefinitionChangedFrom: copyOfOldTrait to: self.!
Item was changed:
----- Method: QuickStack>>initialize (in category 'initialization') -----
initialize
+ top := 0!
- top _ 0!
Item was changed:
----- Method: TraitMethodDescription>>isConflict (in category 'testing') -----
isConflict
| count |
+ count := 0.
- count _ 0.
self methodsDo: [:each |
each isProvided ifTrue: [
+ count := count + 1.
- count _ count + 1.
count > 1 ifTrue: [^true]]].
^false!
Item was changed:
----- Method: TraitAlias>>aliasesForSelector: (in category 'enquiries') -----
aliasesForSelector: aSymbol
| selectors |
+ selectors := self aliases
- selectors _ self aliases
select: [:association | association value = aSymbol]
thenCollect: [:association | association key].
^(super aliasesForSelector: aSymbol)
addAll: selectors;
yourself
!
Item was changed:
----- 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 _ 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.
- 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.
- 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))
!
Item was changed:
----- Method: TraitMethodDescription>>selector: (in category 'accessing') -----
selector: aSymbol
+ selector := aSymbol!
- selector _ aSymbol!
Item was changed:
----- 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 _ 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
"!
Item was changed:
Object subclass: #TraitMethodDescription
instanceVariableNames: 'selector locatedMethods'
+ classVariableNames: 'ConflictMethods RequiredMethods'
- 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.
!
Item was changed:
----- Method: QuickStack>>removeLast (in category 'accessing') -----
removeLast
| answer |
+ answer := self at: top.
+ top := top - 1.
- answer _ self at: top.
- top _ top - 1.
^ answer!
Item was changed:
----- 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 _ self.
temp error: 4 + 5!
Item was changed:
----- Method: TraitMethodDescription>>conflictMethod (in category 'accessing') -----
conflictMethod
| templateMethod argumentNames binary numberOfArguments |
self isConflict ifFalse: [^nil].
+ argumentNames := self getArgumentNames.
+ binary := self isBinarySelector.
+ numberOfArguments := binary
- argumentNames _ self getArgumentNames.
- binary _ self isBinarySelector.
- numberOfArguments _ binary
ifTrue: [1]
ifFalse: [argumentNames size + 2].
+ templateMethod := self conflictMethodForArguments: numberOfArguments ifAbsentPut: [
- templateMethod _ self conflictMethodForArguments: numberOfArguments ifAbsentPut: [
self
generateTemplateMethodWithMarker: CompiledMethod conflictMarker
forArgs: argumentNames size
binary: binary].
^templateMethod copyWithTempNames: argumentNames
!
Item was changed:
----- Method: TraitTransformation>>subject: (in category 'accessing') -----
subject: aTraitTransformation
+ subject := aTraitTransformation!
- subject _ aTraitTransformation!
Item was changed:
----- Method: LocatedMethod>>argumentNames (in category 'comparing') -----
argumentNames
"Return an array with the argument names of the method's selector"
| keywords stream argumentNames argumentName delimiters |
+ delimiters := {Character space. Character cr}.
+ keywords := self selector keywords.
+ stream := self source readStream.
+ argumentNames := OrderedCollection new.
- 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.
- argumentName _ ReadWriteStream on: String new.
[(delimiters includes: stream peek) or: [stream peek isNil]]
whileFalse: [argumentName nextPut: stream next].
argumentName isEmpty ifFalse: [
argumentNames add: argumentName contents withBlanksTrimmed]].
^(argumentNames copyFrom: 1 to: self method numArgs) asArray!
Item was changed:
----- Method: TraitComposition>>initialize (in category 'initialize-release') -----
initialize
super initialize.
+ transformations := OrderedCollection new!
- transformations _ OrderedCollection new!
Item was changed:
----- Method: TraitBehavior>>methodDict: (in category 'accessing method dictionary') -----
methodDict: aDictionary
+ methodDict := aDictionary!
- methodDict _ aDictionary!
Item was changed:
----- 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)
- 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)
!
Item was changed:
----- Method: Behavior>>classAndMethodFor:do:ifAbsent: (in category '*Traits-requires') -----
classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock
"Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated
with the class that defines the selector and the associated method. Otherwise
absentBlock is evaluated."
| method |
self withAllSuperclassesDo: [:class |
+ method := class compiledMethodAt: aSymbol ifAbsent: [nil].
- method _ class compiledMethodAt: aSymbol ifAbsent: [nil].
method ifNotNil: [^ binaryBlock value: class value: method].
].
^ absentBlock value.!
Item was changed:
----- Method: FixedIdentitySet>>initializeCapacity: (in category 'initialize-release') -----
initializeCapacity: anInteger
+ tally := 0.
+ capacity := anInteger.!
- tally _ 0.
- capacity _ anInteger.!
Item was changed:
----- 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 _ 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.!
Item was changed:
----- Method: TimeMeasuringTest>>openDebuggerOnFailingTestMethod (in category 'as yet unclassified') -----
openDebuggerOnFailingTestMethod
+ shouldProfile := true!
- shouldProfile _ true!
Item was changed:
----- 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].
- lines _ self methodDict values inject: 0 into: [:sum :each | sum + each linesOfCode].
self isMeta
ifTrue: [^ lines]
ifFalse: [^ lines + self class linesOfCode]!
Item was changed:
----- 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.
- ifTrue: [isStartOfBlock _ false.
numBlockArgs timesRepeat: [self push: #stuff]]!
Item was changed:
----- Method: SendInfo>>addClassSentSelector: (in category 'private') -----
addClassSentSelector: aSymbol
+ classSentSelectors ifNil: [classSentSelectors := IdentitySet new].
- classSentSelectors ifNil: [classSentSelectors _ IdentitySet new].
classSentSelectors add: aSymbol.!
Item was changed:
----- Method: Trait>>name: (in category 'accessing') -----
name: aSymbol
+ name := aSymbol!
- name _ aSymbol!
Item was changed:
----- 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 _ (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])!
Item was changed:
----- Method: TraitBehavior>>zapAllMethods (in category 'accessing method dictionary') -----
zapAllMethods
"Remove all methods in this trait which is assumed to be obsolete"
+ methodDict := MethodDictionary new.
- methodDict _ MethodDictionary new.
self hasClassTrait ifTrue: [self classTrait zapAllMethods]!
Item was changed:
----- Method: RequiredSelectors>>newlyInterestingClasses (in category 'accessing') -----
newlyInterestingClasses
+ newlyInterestingClasses ifNil: [newlyInterestingClasses := IdentitySet new].
- newlyInterestingClasses ifNil: [newlyInterestingClasses _ IdentitySet new].
^newlyInterestingClasses!
Item was added:
+ ----- Method: SendInfo>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') -----
+ pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize
+ "Simulate the action of a 'closure copy' bytecode whose result is the
+ new BlockClosure for the following code"
+ self pop: numCopied.
+ self push: #block.
+ savedStacks at: (self pc + blockSize) 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.
+ numCopied + numArgs timesRepeat: [self push: #stuff]!
Item was changed:
----- 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 _ self instanceSide organization.
^org classComment isEmptyOrNil not!
Item was added:
+ ----- Method: SendInfo>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') -----
+ popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
+ "Simulate the action of bytecode that removes the top of the stack and stores
+ it into an offset in one of my local variables being used as a remote temp vector."
+
+ self pop!
Item was added:
+ ----- Method: TraitBehavior>>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).
+ !
Item was changed:
----- Method: SendInfo>>newEmptyStack (in category 'stack manipulation') -----
newEmptyStack
+ stack := QuickStack new!
- stack _ QuickStack new!
Item was changed:
----- Method: TraitBehavior>>traitComposition (in category 'traits') -----
traitComposition
+ traitComposition ifNil: [traitComposition := TraitComposition new].
- traitComposition ifNil: [traitComposition _ TraitComposition new].
^traitComposition!
Item was changed:
----- 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 _ self organization commentRemoteStr) isNil or:
[aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self].
aFileStream cr; nextPut: $!!.
+ header := String streamContents: [:strm | strm nextPutAll: self name;
- header _ String streamContents: [:strm | strm nextPutAll: self name;
nextPutAll: ' commentStamp: '.
+ (aStamp := self organization commentStamp ifNil: ['<historical>']) storeOn: strm.
- (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!
Item was changed:
----- Method: FixedIdentitySet>>printOn: (in category 'printing') -----
printOn: aStream
| count |
aStream nextPutAll: '#('.
+ count := 0.
- count _ 0.
self do: [:each |
+ count := count + 1.
- count _ count + 1.
each printOn: aStream.
count < self size ifTrue: [aStream nextPut: $ ]
].
aStream nextPut: $).!
Item was changed:
----- Method: TraitExclusion>>exclusions: (in category 'accessing') -----
exclusions: aCollection
+ exclusions := aCollection!
- exclusions _ aCollection!
1
0
04 Sep '09
A new version of Monticello was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/Monticello-gk.322.mcz
==================== Summary ====================
Name: Monticello-gk.322
Author: gk
Time: 4 September 2009, 11:50:07 am
UUID: 286d43f9-35d8-4ed5-a897-4392bfd088dd
Ancestors: Monticello-ar.321, Monticello-gk.313
Merged our small changes with trunk.
=============== Diff against Monticello-gk.313 ===============
Item was added:
+ ----- Method: MCScriptDefinition class>>scriptSelector:script:packageName: (in category 'as yet unclassified') -----
+ scriptSelector: selectorString script: aString packageName: packageString
+ ^ (self subclassForScriptSelector: selectorString)
+ script: aString packageName: packageString!
Item was changed:
+ ----- Method: MCScriptDefinition>>source (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>source (in category 'as yet unclassified') -----
source
^ script!
Item was changed:
----- Method: MCVersionInspector>>pickRepository (in category 'morphic ui') -----
pickRepository
| index |
+ index := UIManager default chooseFrom: (self repositories collect: [:ea | ea description])
+ title: 'Repository:'.
- index := (PopUpMenu labelArray: (self repositories collect: [:ea | ea description]))
- startUpWithCaption: 'Repository:'.
^ index = 0 ifFalse: [self repositories at: index]!
Item was added:
+ ----- Method: MCScriptDefinition>>packageName (in category 'accessing') -----
+ packageName
+ ^ packageName!
Item was changed:
----- Method: MCWorkingCopyBrowser>>pickAncestorVersionInfo (in category 'morphic ui') -----
pickAncestorVersionInfo
| ancestors index |
ancestors := workingCopy ancestry breadthFirstAncestors.
+ index := UIManager default chooseFrom: (ancestors collect: [:ea | ea name])
+ title: 'Ancestor:'.
- index := (PopUpMenu labelArray: (ancestors collect: [:ea | ea name]))
- startUpWithCaption: 'Ancestor:'.
^ index = 0 ifFalse: [ ancestors at: index]!
Item was added:
+ ----- Method: MCPoolImportDefinition>>isOrderDependend (in category 'testing') -----
+ isOrderDependend
+ ^false!
Item was changed:
+ ----- Method: MCScriptDefinition>>initializeWithScript:packageName: (in category 'initializing') -----
- ----- Method: MCScriptDefinition>>initializeWithScript:packageName: (in category 'as yet unclassified') -----
initializeWithScript: aString packageName: packageString
script := aString.
packageName := packageString!
Item was changed:
+ ----- Method: MCScriptDefinition>>evaluate (in category 'installing') -----
- ----- Method: MCScriptDefinition>>evaluate (in category 'as yet unclassified') -----
evaluate
Compiler evaluate: script!
Item was added:
+ ----- Method: MCClassVariableDefinition>>isOrderDependend (in category 'as yet unclassified') -----
+ isOrderDependend
+ ^false!
Item was changed:
----- Method: MCHttpRepository>>user (in category 'as yet unclassified') -----
user
self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr].
"not in settings"
+ ^user ifNil: ['']!
- ^user!
Item was changed:
----- Method: MCVersionInspector>>pickAncestor (in category 'morphic ui') -----
pickAncestor
| index versions |
versions := self version info breadthFirstAncestors.
+ index := UIManager default chooseFrom: (versions collect: [:ea | ea name])
+ title: 'Ancestor:'.
- index := (PopUpMenu labelArray: (versions collect: [:ea | ea name]))
- startUpWithCaption: 'Ancestor:'.
^ index = 0 ifFalse: [versions at: index]!
Item was changed:
----- Method: MCMethodDefinitionTest>>override (in category 'mocks') -----
override ^ 1!
Item was changed:
----- Method: MCClassDefinition>>= (in category 'visiting') -----
= aDefinition
^((super = aDefinition)
and: [superclassName = aDefinition superclassName]
and: [self traitCompositionString = aDefinition traitCompositionString]
and: [self classTraitCompositionString = aDefinition classTraitCompositionString])
and: [category = aDefinition category]
and: [type = aDefinition type]
+ and: [self sortedVariables = aDefinition sortedVariables]
- and: [variables = aDefinition variables]
and: [comment = aDefinition comment]
!
Item was changed:
----- Method: MCWorkingCopyBrowser>>newRepository (in category 'actions') -----
newRepository
| types index |
types := MCRepository allConcreteSubclasses asArray.
+ index := UIManager default chooseFrom: (types collect: [:ea | ea description])
+ title: 'Repository type:'.
- index := (PopUpMenu labelArray: (types collect: [:ea | ea description]))
- startUpWithCaption: 'Repository type:'.
^ index = 0 ifFalse: [(types at: index) morphicConfigure]!
Item was changed:
----- Method: MCPatchBrowser>>methodListMenu: (in category 'menus') -----
methodListMenu: aMenu
selection ifNotNil:
+ [aMenu addList:#(
+ ('install' installSelection)
+ ('revert' revertSelection)
+ -)].
- [aMenu addList:#(('install' installSelection) -)].
super methodListMenu: aMenu.
^ aMenu
!
Item was changed:
+ ----- Method: MCScriptDefinition>>accept: (in category 'visiting') -----
- ----- Method: MCScriptDefinition>>accept: (in category 'as yet unclassified') -----
accept: aVisitor
+ aVisitor visitScriptDefinition: self!
- "do nothing for now - this means it won't appear in the .st file"!
Item was added:
+ ----- Method: MCVariableDefinition>>isOrderDependend (in category 'testing') -----
+ isOrderDependend
+ ^true!
Item was added:
+ ----- Method: MCPatchBrowser>>revertSelection (in category 'actions') -----
+ revertSelection
+ | loader |
+ selection ifNotNil:
+ [loader := MCPackageLoader new.
+ selection inverse applyTo: loader.
+ loader loadWithName: self changeSetNameForInstall ]!
Item was changed:
----- Method: MCSnapshotBrowserTest>>testNoSelection (in category 'testing') -----
testNoSelection
self assertAListMatches: self allCategories.
self denyAListIncludesAnyOf: self definedClasses.
self denyAListIncludesAnyOf: self allProtocols.
self denyAListIncludesAnyOf: self allMethods.
+ "and if there I need to see the packages scripts (or none)"
+ self assertTextIs: '(package defines no scripts)'.!
- self assertTextIs: ''.!
Item was changed:
+ ----- Method: MCClassDefinition>>initializeWithName:superclassName:traitComposition:classTraitComposition:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp: (in category 'initializing') -----
- ----- Method: MCClassDefinition>>initializeWithName:superclassName:traitComposition:classTraitComposition:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp: (in category 'visiting') -----
initializeWithName: nameString
superclassName: superclassString
traitComposition: traitCompositionString
classTraitComposition: classTraitCompositionString
category: categoryString
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampStringOrNil
name := nameString asSymbol.
superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol].
traitComposition := traitCompositionString.
classTraitComposition := classTraitCompositionString.
category := categoryString.
name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol].
comment := commentString withSqueakLineEndings.
commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp].
variables := OrderedCollection new.
self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
+ self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition.
+ self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition.
- self addVariables: cvarArray ofType: MCClassVariableDefinition.
- self addVariables: poolArray ofType: MCPoolImportDefinition.
self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.!
Item was changed:
+ ----- Method: MCScriptDefinition>>installScript: (in category 'installing') -----
- ----- Method: MCScriptDefinition>>installScript: (in category 'as yet unclassified') -----
installScript: aString
| sel pi |
sel := (self scriptSelector, ':') asSymbol.
pi := self packageInfo.
(pi respondsTo: sel)
ifTrue: [pi perform: sel with: aString]!
Item was changed:
+ ----- Method: MCScriptDefinition>>= (in category 'comparing') -----
- ----- Method: MCScriptDefinition>>= (in category 'as yet unclassified') -----
= aDefinition
^ (super = aDefinition)
and: [script = aDefinition script]!
Item was changed:
+ ----- Method: MCScriptDefinition>>sortKey (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>sortKey (in category 'as yet unclassified') -----
sortKey
^ '!!', self scriptSelector "force to the front so it gets loaded first"!
Item was added:
+ MCDoItParser subclass: #MCScriptParser
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Monticello-Chunk Format'!
Item was added:
+ ----- Method: MCScriptParser class>>pattern (in category 'as yet unclassified') -----
+ pattern
+ ^'(PackageInfo named: *'!
Item was changed:
+ ----- Method: MCPatchBrowser>>installSelection (in category 'actions') -----
- ----- Method: MCPatchBrowser>>installSelection (in category 'as yet unclassified') -----
installSelection
| loader |
selection ifNotNil:
[loader := MCPackageLoader new.
selection applyTo: loader.
loader loadWithName: self changeSetNameForInstall ]!
Item was added:
+ ----- Method: MCScriptDefinition class>>subclassForScriptSelector: (in category 'as yet unclassified') -----
+ subclassForScriptSelector: selectorString
+ ^self allSubclasses detect: [:ea | ea scriptSelector = selectorString]!
Item was changed:
+ ----- Method: MCScriptDefinition>>script (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>script (in category 'as yet unclassified') -----
script
^ script!
Item was changed:
----- Method: MCPackageLoader>>basicLoad (in category 'private') -----
basicLoad
errorDefinitions := OrderedCollection new.
+ [[
+
+ "FIXME. Do a separate pass on loading class definitions as the very first thing.
+ This is a workaround for a problem with the so-called 'atomic' loading (you wish!!)
+ which isn't atomic at all but mixes compilation of methods with reshapes of classes.
+
+ Since the method is not installed until later, any class reshape in the middle *will*
+ affect methods in subclasses that have been compiled before. There is probably
+ a better way of dealing with this by ensuring that the sort order of the definition lists
+ superclass definitions before methods for subclasses but I need this NOW, and adding
+ an extra pass ensures that methods are compiled against their new class definitions."
+
+ additions do: [:ea | self loadClassDefinition: ea] displayingProgress: 'Loading classes...'.
+
+ additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Compiling methods...'.
- [[additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'.
removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'.
self shouldWarnAboutErrors ifTrue: [self warnAboutErrors].
errorDefinitions do: [:ea | ea addMethodAdditionTo: methodAdditions] displayingProgress: 'Reloading...'.
methodAdditions do: [:each | each installMethod].
methodAdditions do: [:each | each notifyObservers].
additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...']
on: InMidstOfFileinNotification
do: [:n | n resume: true]]
ensure: [self flushChangesFile]!
Item was changed:
+ ----- Method: MCClassDefinition>>initializeWithName:superclassName:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp: (in category 'initializing') -----
- ----- Method: MCClassDefinition>>initializeWithName:superclassName:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp: (in category 'serializing') -----
initializeWithName: nameString
superclassName: superclassString
category: categoryString
instVarNames: ivarArray
classVarNames: cvarArray
poolDictionaryNames: poolArray
classInstVarNames: civarArray
type: typeSymbol
comment: commentString
commentStamp: stampStringOrNil
name := nameString asSymbol.
superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol].
category := categoryString.
name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol].
comment := commentString withSqueakLineEndings.
commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp].
variables := OrderedCollection new.
self addVariables: ivarArray ofType: MCInstanceVariableDefinition.
+ self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition.
+ self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition.
- self addVariables: cvarArray ofType: MCClassVariableDefinition.
- self addVariables: poolArray ofType: MCPoolImportDefinition.
self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.!
Item was changed:
----- Method: MCPatchBrowser>>widgetSpecs (in category 'morphic ui') -----
widgetSpecs
Preferences annotationPanes ifFalse: [ ^#(
((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 0 0 0))
((textMorph: text) (0 0.4 1 1))
) ].
^ {
+ #((listMorph:selection:menu:keystroke: list selection methodListMenu: methodListKey:from:) (0 0 1 0.4) (0 0 0 0)).
- #((listMorph:selection:menu: list selection methodListMenu: ) (0 0 1 0.4) (0 0 0 0)).
{ #(textMorph: annotations). #(0 0.4 1 0.4). { 0. 0. 0. self defaultAnnotationPaneHeight. } }.
{ #(textMorph: text). #(0 0.4 1 1). { 0. self defaultAnnotationPaneHeight. 0. 0. } }.
}!
Item was changed:
+ ----- Method: MCScriptDefinition>>scriptSelector (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>scriptSelector (in category 'as yet unclassified') -----
scriptSelector
^ self class scriptSelector!
Item was changed:
----- Method: ChangeList class>>recentLogOn:startingFrom: (in category '*monticello') -----
recentLogOn: origChangesFile startingFrom: initialPos
"Prompt with a menu of how far back to go when browsing a changes file."
| end banners positions pos chunk i changesFile |
changesFile := origChangesFile readOnlyCopy.
banners := OrderedCollection new.
positions := OrderedCollection new.
end := changesFile size.
pos := initialPos.
[pos = 0
or: [banners size > 20]]
whileFalse: [changesFile position: pos.
chunk := changesFile nextChunk.
i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
i > 0
ifTrue: [positions addLast: pos.
banners
addLast: (chunk copyFrom: 5 to: i - 2).
pos := Number
readFrom: (chunk copyFrom: i + 13 to: chunk size)]
ifFalse: [pos := 0]].
changesFile close.
banners size == 0 ifTrue: [^self recent: end on: origChangesFile].
+ pos := UIManager default chooseFrom: banners values: positions
+ title: 'Browse as far back as...'.
- pos := (SelectionMenu labelList: banners selections: positions)
- startUpWithCaption: 'Browse as far back as...'.
pos == nil
ifTrue: [^ self].
^self recent: end - pos on: origChangesFile!
Item was changed:
----- Method: MCSnapshotBrowser>>text (in category 'text') -----
text
self switchIsComment ifTrue: [^ self classCommentString].
methodSelection ifNotNil: [^ methodSelection source].
protocolSelection ifNotNil: [^ ''].
classSelection ifNotNil: [^ self classDefinitionString].
+ categorySelection ifNil: [^self scriptDefinitionString].
^ ''!
Item was changed:
----- Method: MCWorkingCopyBrowser>>pickWorkingCopySatisfying: (in category 'morphic ui') -----
pickWorkingCopySatisfying: aBlock
| copies index |
copies := self workingCopies select: aBlock.
copies isEmpty ifTrue: [ ^nil ].
+ index := UIManager default chooseFrom: (copies collect: [:ea | ea packageName])
+ title: 'Package:'.
- index := (PopUpMenu labelArray: (copies collect: [:ea | ea packageName]))
- startUpWithCaption: 'Package:'.
^ index = 0 ifFalse: [ copies at: index]!
Item was added:
+ ----- Method: MCStWriter>>visitScriptDefinition: (in category 'visiting') -----
+ visitScriptDefinition: definition
+ self writeScriptDefinition: definition
+ !
Item was added:
+ ----- Method: MCSnapshotBrowser>>scriptDefinitionString (in category 'text') -----
+ scriptDefinitionString
+ | defs |
+ defs := items select: [:ea | ea isScriptDefinition].
+ defs isEmpty ifTrue: [^'(package defines no scripts)'].
+
+ ^ String streamContents: [:stream |
+ defs asArray sort
+ do: [:ea | stream nextPutAll: '---------- package ';
+ nextPutAll: ea scriptSelector;
+ nextPutAll: ' ----------'; cr;
+ nextPutAll: ea script; cr]
+ separatedBy: [stream cr]].!
Item was changed:
----- Method: MCTool>>buildWindow (in category 'morphic ui') -----
buildWindow
| window |
window := SystemWindow labelled: self label.
window model: self.
+ self widgetSpecs do: [:spec |
+ | send fractions offsets |
+ send := spec first.
+ fractions := spec at: 2 ifAbsent: [#(0 0 1 1)].
+ offsets := spec at: 3 ifAbsent: [#(0 0 0 0)].
- self widgetSpecs do:
- [:pair | |send fractions offsets|
- send := pair first.
- fractions := pair at: 2 ifAbsent: [#(0 0 1 1)].
- offsets := pair at: 3 ifAbsent: [#(0 0 0 0)].
window
+ addMorph: (self perform: send first withArguments: send allButFirst)
- addMorph: (self perform: send first withArguments: send allButFirst )
fullFrame:
(LayoutFrame
fractions:
+ ((fractions first)@(fractions second) corner:
+ (fractions third)@(fractions fourth))
- ((fractions first)@(fractions second) corner:
- (fractions third)@(fractions fourth))
offsets:
((offsets first)@(offsets second) corner:
(offsets third)@(offsets fourth)))].
^ window!
Item was added:
+ ----- Method: MCPackageLoader>>loadClassDefinition: (in category 'private') -----
+ loadClassDefinition: aDefinition
+ [aDefinition isClassDefinition ifTrue:[aDefinition load]] on: Error do: [errorDefinitions add: aDefinition].!
Item was changed:
+ ----- Method: MCScriptDefinition>>installScript (in category 'installing') -----
- ----- Method: MCScriptDefinition>>installScript (in category 'as yet unclassified') -----
installScript
self installScript: script!
Item was changed:
+ ----- Method: MCScriptDefinition>>packageInfo (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>packageInfo (in category 'as yet unclassified') -----
packageInfo
^ PackageInfo named: packageName!
Item was added:
+ ----- Method: MCDefinition>>isScriptDefinition (in category 'testing') -----
+ isScriptDefinition
+ ^false!
Item was changed:
+ ----- Method: MCScriptDefinition>>summary (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>summary (in category 'as yet unclassified') -----
summary
^ packageName, ' ', self scriptSelector!
Item was changed:
----- Method: MCDictionaryRepository>>morphicOpen: (in category 'as yet unclassified') -----
morphicOpen: aWorkingCopy
| names index infos |
infos := self sortedVersionInfos.
infos isEmpty ifTrue: [^ self inform: 'No versions'].
names := infos collect: [:ea | ea name].
+ index := UIManager default chooseFrom: names title: 'Open version:'.
- index := (PopUpMenu labelArray: names) startUpWithCaption: 'Open version:'.
index = 0 ifFalse: [(self versionWithInfo: (infos at: index)) open]!
Item was changed:
+ ----- Method: MCScriptDefinition>>load (in category 'installing') -----
- ----- Method: MCScriptDefinition>>load (in category 'as yet unclassified') -----
load
self installScript!
Item was changed:
----- Method: MCHttpRepository>>password (in category 'as yet unclassified') -----
password
self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd].
+ self user isEmpty ifTrue: [^password ifNil: ['']].
- self user isEmpty ifTrue: [^password].
+ [password isEmptyOrNil] whileTrue: [
- [password isEmpty] whileTrue: [
| answer |
"Give the user a chance to change the login"
+ answer := UIManager default request: 'User name for ', String cr, location
- answer := FillInTheBlank request: 'User name for ', String cr, location
initialAnswer: self user.
answer isEmpty
ifTrue: [^password]
ifFalse: [self user: answer].
+ password := UIManager default requestPassword: 'Password for "', self user, '" at ', String cr, location.
- password := FillInTheBlank requestPassword: 'Password for "', self user, '" at ', String cr, location.
].
^ password!
Item was added:
+ ----- Method: MCScriptParser>>addDefinitionsTo: (in category 'as yet unclassified') -----
+ addDefinitionsTo: aCollection
+ | tokens definition |
+ tokens := Scanner new scanTokens: source.
+ definition := MCScriptDefinition
+ scriptSelector: tokens second allButLast
+ script: tokens third
+ packageName: tokens first third.
+ aCollection add: definition.!
Item was added:
+ ----- Method: MCStWriter>>writeScriptDefinition: (in category 'writing') -----
+ writeScriptDefinition: definition
+ stream nextChunkPut: (
+ '(PackageInfo named: {1}) {2}: {3}'
+ format: {
+ "{1}" definition packageName printString.
+ "{2}" definition scriptSelector.
+ "{3}" definition script printString
+ }); cr!
Item was added:
+ ----- Method: MCClassDefinition>>sortedVariables (in category 'accessing') -----
+ sortedVariables
+ "sort variables for comparison purposes"
+
+ | sorted |
+ sorted := variables select: [:var | var isOrderDependend].
+ sorted addAll: ((variables reject: [:var | var isOrderDependend])
+ asSortedCollection: [:a :b | a name <= b name]).
+ ^sorted!
Item was changed:
+ ----- Method: MCScriptDefinition>>description (in category 'accessing') -----
- ----- Method: MCScriptDefinition>>description (in category 'as yet unclassified') -----
description
^ Array with: packageName with: self scriptSelector!
Item was added:
+ ----- Method: MCScriptDefinition>>isScriptDefinition (in category 'testing') -----
+ isScriptDefinition
+ ^true!
Item was changed:
+ ----- Method: MCScriptDefinition>>unload (in category 'installing') -----
- ----- Method: MCScriptDefinition>>unload (in category 'as yet unclassified') -----
unload
self installScript: nil!
Item was removed:
- ----- Method: MCPostscriptDefinition>>accept: (in category 'as yet unclassified') -----
- accept: aWriter
- "do nothing"!
1
0
DeltaStreams: DeltaStreams-Installer-gk.3.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of DeltaStreams-Installer was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-Installer-gk.3.mcz
==================== Summary ====================
Name: DeltaStreams-Installer-gk.3
Author: gk
Time: 4 September 2009, 11:21:13 am
UUID: ba9adfbc-4b84-4bc3-81bf-13f7545f086a
Ancestors: DeltaStreams-Installer-gk.2
Fixes in installer script.
=============== Diff against DeltaStreams-Installer-gk.2 ===============
Item was changed:
----- Method: DSInstaller class>>install (in category 'as yet unclassified') -----
install
+ "DSInstaller install"
- " Installer installUrl:
- 'http://map.squeak.org/account/files/SystemChangeNotification-Improvements39…'.
+ Installer squeaksource
+
+ project: 'SystemEditor'; "Main mechanism used for actual Delta apply"
- Installer installUrl:
- 'http://map.squeak.org/accountbyid/d39eae5e-4c3e-4335-bc65-b158ea4e489e/file…'.
-
- "
- Installer squeaksource
- project: 'SystemEditor'; "Main mechanism used for actual Delta apply"
install: 'SystemEditor-Core';
install: 'SystemEditor-Squeak';
install: 'SystemEditor-Traits';
install: 'SystemEditor-Tests';
install: 'SystemEditorBrowser';
+ project: 'Tirade'; "This is used for serialization/deserialization - not essential unless you need to store Deltas"
+ install: 'Tirade';
+ install: 'Tirade-Tests';
+
+ project: 'DeltaStreams';
+ install: 'System'; "Fixes for change notifications"
+ install: 'Traits'; "Fixes for change notifications"
+ install: 'Monticello'; "Fixes for change notifications"
+
- project: 'DeltaStreams';
- install: 'Tirade'; "This is used for serialization/deserialization - not essential unless you need to store Deltas"
- " install: 'InterleavedChangeSet'; This is a complex cs+binary format that we do not work on anymore, NOT USED"
- install: 'Monticello'; "Fixes for change notifications"
- install: 'System'; "Fixes for change notifications"
- install: 'Traits'; "Fixes for change notifications"
install: 'DeltaStreams-Model'; "Domain model of Deltas"
+ install: 'DeltaStreams-Logging'; "Extensions for hooking into SystemChangeNotification in Squeak"
+ install: 'DeltaStreams-Tirade'; "Support for filing out/in Deltas in Tirade syntax"
- install: 'DeltaStreams-Logging'; "Extensions for hooking into SystemChangeNotification in Squeak"
- " install: 'DeltaStreams-Storing'; This is to support InterleavedChangeSet above, NOT USED"
- install: 'DeltaStreams-Tirade'; "Support for filing out/in Deltas in Tirade syntax"
install: 'DeltaStreams-Tests'; "All the tests for all packages"
install: 'DeltaStreams-Deprecated'. "Old stuff being thrown away eventually"
+
- " install: 'DeltaStreams-UI'. This is the first UI by Matthew that mimics a SystemBrowser kinda"
self inform: 'DeltaStreams successfully installed!! Time to put your helmet on.'
!
1
0
DeltaStreams: DeltaStreams-Installer-gk.2.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of DeltaStreams-Installer was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-Installer-gk.2.mcz
==================== Summary ====================
Name: DeltaStreams-Installer-gk.2
Author: gk
Time: 4 September 2009, 10:49:39 am
UUID: 628df396-c25e-42d8-9458-88f0c54503db
Ancestors: DeltaStreams-Installer-gk.1
Comments.
=============== Diff against DeltaStreams-Installer-gk.1 ===============
Item was changed:
----- Method: DSInstaller class>>install (in category 'as yet unclassified') -----
install
" Installer installUrl:
'http://map.squeak.org/account/files/SystemChangeNotification-Improvements39…'.
Installer installUrl:
'http://map.squeak.org/accountbyid/d39eae5e-4c3e-4335-bc65-b158ea4e489e/file…'.
"
Installer squeaksource
+ project: 'SystemEditor'; "Main mechanism used for actual Delta apply"
- project: 'SystemEditor';
install: 'SystemEditor-Core';
install: 'SystemEditor-Squeak';
install: 'SystemEditor-Traits';
install: 'SystemEditor-Tests';
install: 'SystemEditorBrowser';
project: 'DeltaStreams';
+ install: 'Tirade'; "This is used for serialization/deserialization - not essential unless you need to store Deltas"
+ " install: 'InterleavedChangeSet'; This is a complex cs+binary format that we do not work on anymore, NOT USED"
+ install: 'Monticello'; "Fixes for change notifications"
+ install: 'System'; "Fixes for change notifications"
+ install: 'Traits'; "Fixes for change notifications"
+ install: 'DeltaStreams-Model'; "Domain model of Deltas"
+ install: 'DeltaStreams-Logging'; "Extensions for hooking into SystemChangeNotification in Squeak"
+ " install: 'DeltaStreams-Storing'; This is to support InterleavedChangeSet above, NOT USED"
+ install: 'DeltaStreams-Tirade'; "Support for filing out/in Deltas in Tirade syntax"
+ install: 'DeltaStreams-Tests'; "All the tests for all packages"
+ install: 'DeltaStreams-Deprecated'. "Old stuff being thrown away eventually"
- install: 'Tirade';
- " install: 'InterleavedChangeSet'; This is a complex cs+binary format that we do not work on anymore"
- install: 'Monticello';
- install: 'System';
- install: 'Traits';
- install: 'DeltaStreams-Model';
- install: 'DeltaStreams-Logging';
- " install: 'DeltaStreams-Storing'; This is to support InterleavedChangeSet above"
- install: 'DeltaStreams-Tirade';
- install: 'DeltaStreams-Tests';
- install: 'DeltaStreams-Deprecated'.
" install: 'DeltaStreams-UI'. This is the first UI by Matthew that mimics a SystemBrowser kinda"
+ self inform: 'DeltaStreams successfully installed!! Time to put your helmet on.'
-
!
1
0
DeltaStreams: DeltaStreams-Installer-gk.1.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of DeltaStreams-Installer was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-Installer-gk.1.mcz
==================== Summary ====================
Name: DeltaStreams-Installer-gk.1
Author: gk
Time: 4 September 2009, 10:38:34 am
UUID: 591437f4-c041-4c32-90c8-bfe7b22ca4c8
Ancestors:
First try for an Installer based script.
==================== Snapshot ====================
SystemOrganization addCategory: #'DeltaStreams-Installer'!
Object subclass: #DSInstaller
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DeltaStreams-Installer'!
----- Method: DSInstaller class>>install (in category 'as yet unclassified') -----
install
" Installer installUrl:
'http://map.squeak.org/account/files/SystemChangeNotification-Improvements39…'.
Installer installUrl:
'http://map.squeak.org/accountbyid/d39eae5e-4c3e-4335-bc65-b158ea4e489e/file…'.
"
Installer squeaksource
project: 'SystemEditor';
install: 'SystemEditor-Core';
install: 'SystemEditor-Squeak';
install: 'SystemEditor-Traits';
install: 'SystemEditor-Tests';
install: 'SystemEditorBrowser';
project: 'DeltaStreams';
install: 'Tirade';
" install: 'InterleavedChangeSet'; This is a complex cs+binary format that we do not work on anymore"
install: 'Monticello';
install: 'System';
install: 'Traits';
install: 'DeltaStreams-Model';
install: 'DeltaStreams-Logging';
" install: 'DeltaStreams-Storing'; This is to support InterleavedChangeSet above"
install: 'DeltaStreams-Tirade';
install: 'DeltaStreams-Tests';
install: 'DeltaStreams-Deprecated'.
" install: 'DeltaStreams-UI'. This is the first UI by Matthew that mimics a SystemBrowser kinda"
!
1
0
04 Sep '09
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!
1
0
Interleaved Change Set: InterleavedChangeSet-gk.9.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of InterleavedChangeSet was added to project Interleaved Change Set:
http://www.squeaksource.com/InterleavedChangeSet/InterleavedChangeSet-gk.9.…
==================== Summary ====================
Name: InterleavedChangeSet-gk.9
Author: gk
Time: 4 September 2009, 9:52:04 am
UUID: 055a981c-b643-475c-840b-9d265ce926cd
Ancestors: InterleavedChangeSet-mtf.8
Tiny stamp: fix.
=============== Diff against InterleavedChangeSet-mtf.8 ===============
Item was changed:
SharedPool subclass: #ICSConstants
instanceVariableNames: ''
+ classVariableNames: 'PopEntry MakeClass AddClass ActionMap SetProperty ClassEntry FileTableEntry Pop UnknownEntry AddProperty PushEntry MethodEntry PushNew'
- classVariableNames: 'AddClass MakeClass PushNew ActionMap SetProperty FileTableEntry ClassEntry Pop AddProperty PopEntry UnknownEntry MethodEntry PushEntry'
poolDictionaries: ''
category: 'InterleavedChangeSet'!
Item was changed:
----- Method: ICSMethodEntryWriter>>writeMethodEntryFor:className:meta:selector:source:stamp:protocol:properties: (in category 'as yet unclassified') -----
writeMethodEntryFor: modelClass
className: methodClass
meta: meta
selector: methodSelector
source: methodSource
stamp: methodStamp
protocol: methodProtocol
properties: properties
"Write out an entry to load a method"
"Loading instructions"
self pushNewClass: modelClass.
self setProperty: #className.
self setProperty: #meta.
self setProperty: #selector.
self setProperty: #source.
self setProperty: #protocol.
self setProperty: #timeStamp.
+ self setProperty: #stamp.
self writeAndSetProperties: properties.
self pop.
"Properties not is the file-out"
self stringStreamPut: methodSelector forProperty: #selector.
"Write the method chunk"
chunkStream nextPut: $!!.
self chunkStreamPut: methodClass forProperty: #className.
self chunkStreamPut: (meta ifFalse: [''] ifTrue: [' class']) forProperty: #meta.
chunkStream nextPutAll: ' methodsFor: '''.
self chunkStreamPut: methodProtocol forProperty: #protocol.
chunkStream nextPutAll: ''' stamp: '''.
self chunkStreamPut: methodStamp forProperty: #stamp.
chunkStream nextPutAll: '''!!'; cr.
self chunkStreamPut: methodSource asString forProperty: #source.
chunkStream nextPutAll: '!! !!'; cr; cr.!
1
0
04 Sep '09
A new version of DeltaStreams-UI was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-UI-gk.7.mcz
==================== Summary ====================
Name: DeltaStreams-UI-gk.7
Author: gk
Time: 4 September 2009, 9:50:45 am
UUID: 6042ad6d-7b61-43ee-aaee-34a72188de2f
Ancestors: DeltaStreams-UI-mtf.6
Small removals. I am probably not touching this package anymore.
=============== Diff against DeltaStreams-UI-mtf.6 ===============
Item was removed:
- ----- Method: DSDelta>>classGroupNamed: (in category '*deltastreams-ui') -----
- classGroupNamed: aClassName
- "Answers all the changes to the class with this name"
-
- ^ self classGroupFor: (DSBasicClassChange className: aClassName)!
Item was removed:
- DSChangeSequence subclass: #DSFilter
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'DeltaStreams-UI'!
-
- !DSFilter commentStamp: '<historical>' prior: 0!
- I am a class that should exist, but my features are burried in other places. So, for now, I am just a placeholder comment for a future refactoring. I should be responsible for:
- - Keeping track of which things in a DSChangeSequence are selected, or visible in a UI, kind of like a Tweak costume. This is currently kept track of by the shownChangeIndexes and changeListSelection ivars of DSDeltaStreamBrowser
- - Executing queries on present and incoming changes, and using the results to determine selection status. This is currently split between various menu entry methods in DSDeltaStreamBrowser, and the grouping methods of DSChange
- - I should also, perhaps, take responsibility for presenting a costume for changes in my wrapped change, so that they can be associated with view-specific properties, such as highlight color, or selected changes if I am a heiarchial change. Some of this is being done by DSUIApplier!
1
0
DeltaStreams: DeltaStreams-Tirade-gk.2.mcz
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
by squeak-dev-noreply＠lists.squeakfoundation.org 04 Sep '09
04 Sep '09
A new version of DeltaStreams-Tirade was added to project DeltaStreams:
http://www.squeaksource.com/DeltaStreams/DeltaStreams-Tirade-gk.2.mcz
==================== Summary ====================
Name: DeltaStreams-Tirade-gk.2
Author: gk
Time: 4 September 2009, 9:21:15 am
UUID: 7c6dee17-ef32-461b-8ddc-ec98ad8b0293
Ancestors: DeltaStreams-Tirade-gk.1
Tirade hooked fully into the domain model etc. Now Deltas can be stored and loaded in Tirade format.
=============== Diff against DeltaStreams-Tirade-gk.1 ===============
Item was added:
+ ----- Method: DSClassChange>>tiradeClassInstVarNames: (in category '*deltastreams-tirade') -----
+ tiradeClassInstVarNames: value
+ self classInstVarNames: value!
Item was added:
+ ----- Method: DSClassSuperclassChange>>tiradeSuperclassName: (in category '*deltastreams-tirade') -----
+ tiradeSuperclassName: assoc
+ self oldSuperclassName: assoc key.
+ self superclassName: assoc value!
Item was changed:
TiradeReader subclass: #DSTiradeReader
+ instanceVariableNames: 'deltas composites'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'DeltaStreams-Tirade'!
Item was added:
+ ----- Method: DSMethodProtocolChange>>tiradeCategory (in category '*deltastreams-tirade') -----
+ tiradeCategory
+ ^oldProtocol -> protocol!
Item was added:
+ ----- Method: DSClassTypeChange>>tiradeType (in category '*deltastreams-tirade') -----
+ tiradeType
+ ^oldType -> type!
Item was added:
+ ----- Method: DSMethodSourceChange>>tiradeSource: (in category '*deltastreams-tirade') -----
+ tiradeSource: assoc
+ self oldSource: assoc key;
+ source: assoc value!
Item was added:
+ ----- Method: DSMethodChange>>tiradeCategory: (in category '*deltastreams-tirade') -----
+ tiradeCategory: value
+ protocol := value!
Item was added:
+ ----- Method: DSTiradeReader>>endComposite (in category 'tirade') -----
+ endComposite
+ "Remove from stack."
+
+ composites removeLast!
Item was added:
+ ----- Method: DSTiradeReader>>result (in category 'reading') -----
+ result
+ ^deltas!
Item was added:
+ ----- Method: DSClassCategoryChange>>tiradeCategory: (in category '*deltastreams-tirade') -----
+ tiradeCategory: assoc
+ self oldCategory: assoc key.
+ self category: assoc value!
Item was added:
+ ----- Method: DSMethodChange>>tiradeSelector: (in category '*deltastreams-tirade') -----
+ tiradeSelector: value
+ self selector: value!
Item was added:
+ ----- Method: DSClassChange>>tiradeInstVarNames: (in category '*deltastreams-tirade') -----
+ tiradeInstVarNames: value
+ self instVarNames: value!
Item was added:
+ ----- Method: DSClassCommentChange>>tiradeStamp: (in category '*deltastreams-tirade') -----
+ tiradeStamp: assoc
+ self oldStamp: assoc key;
+ stamp: assoc value!
Item was added:
+ ----- Method: DSClassChange>>tiradeInstVarNames (in category '*deltastreams-tirade') -----
+ tiradeInstVarNames
+ ^self instVarNames!
Item was added:
+ ----- Method: DSMethodProtocolChange>>tiradeCategory: (in category '*deltastreams-tirade') -----
+ tiradeCategory: assoc
+ self oldProtocol: assoc key;
+ protocol: assoc value!
Item was added:
+ ----- Method: DSTiradeReader>>initialize (in category 'initialize-release') -----
+ initialize
+
+ super initialize.
+ composites := OrderedCollection new.
+ deltas := OrderedCollection new.
+ result := self. "making sure first message is sent to me, see #performMessage"
+ self controlMessages: #(beginComposite. endComposite. beginChanges. endChanges. endDelta)!
Item was added:
+ ----- Method: DSClassChange>>tiradePoolDictionaryNames: (in category '*deltastreams-tirade') -----
+ tiradePoolDictionaryNames: value
+ self poolDictionaryNames: value!
Item was added:
+ ----- Method: DSSharedPoolVarsChange>>tiradePoolDictionaryNames (in category '*deltastreams-tirade') -----
+ tiradePoolDictionaryNames
+ ^oldVars -> poolDictionaryNames!
Item was added:
+ ----- Method: DSClassChange>>tiradeSuperclassName: (in category '*deltastreams-tirade') -----
+ tiradeSuperclassName: value
+ self superclassName: value!
Item was added:
+ ----- Method: DSClassTypeChange>>tiradeType: (in category '*deltastreams-tirade') -----
+ tiradeType: assoc
+ self oldType: assoc key.
+ self type: assoc value!
Item was added:
+ ----- Method: DSClassInstVarsChange>>tiradeClassInstVarNames: (in category '*deltastreams-tirade') -----
+ tiradeClassInstVarNames: assoc
+ self oldVars: assoc key.
+ self classInstVarNames: assoc value!
Item was added:
+ ----- Method: DSSharedPoolVarsChange>>tiradePoolDictionaryNames: (in category '*deltastreams-tirade') -----
+ tiradePoolDictionaryNames: assoc
+ self oldVars: assoc key.
+ self poolDictionaryNames: assoc value!
Item was added:
+ ----- Method: DSMethodSourceChange>>tiradeSource (in category '*deltastreams-tirade') -----
+ tiradeSource
+ ^oldSource -> source!
Item was added:
+ ----- Method: DSClassChange>>tiradeComment (in category '*deltastreams-tirade') -----
+ tiradeComment
+ ^self comment!
Item was added:
+ ----- Method: DSMethodSourceChange>>tiradeStamp (in category '*deltastreams-tirade') -----
+ tiradeStamp
+ ^oldStamp -> stamp!
Item was added:
+ ----- Method: DSClassChange>>tiradeOn: (in category '*deltastreams-tirade') -----
+ tiradeOn: recorder
+
+ recorder
+ class: self tiradeClassName
+ change: self class name
+ superclassName: self tiradeSuperclassName
+ instVarNames: self tiradeInstVarNames
+ classVarNames: self tiradeClassVarNames
+ poolDictionaryNames: self tiradePoolDictionaryNames
+ category: self tiradeCategory
+ type: self tiradeType
+ classInstVarNames: self tiradeClassInstVarNames
+ comment: self tiradeComment
+ stamp: self tiradeStamp
+ properties: properties!
Item was added:
+ ----- Method: DSTiradeReader>>beginComposite (in category 'tirade') -----
+ beginComposite
+ "Upcoming messages will create changes that we need to put into
+ the previous composite change."
+
+ composites add: lastResult!
Item was added:
+ ----- Method: DSClassChange>>tiradeClassVarNames: (in category '*deltastreams-tirade') -----
+ tiradeClassVarNames: value
+ self classVarNames: value!
Item was added:
+ ----- Method: DSClassChange>>tiradeType (in category '*deltastreams-tirade') -----
+ tiradeType
+ ^self type!
Item was added:
+ ----- Method: DSMethodChange>>tiradeOn: (in category '*deltastreams-tirade') -----
+ tiradeOn: recorder
+ recorder
+ method: self fullClassName -> selector
+ change: self class name
+ category: self tiradeCategory
+ source: self tiradeSource
+ stamp: self tiradeStamp
+ properties: properties!
Item was added:
+ ----- Method: DSTiradeReader>>primitivePerformMessage (in category 'processing') -----
+ primitivePerformMessage
+
+ ^receiver perform: selector asSymbol withArguments: arguments asArray!
Item was added:
+ ----- Method: DSInstVarsChange>>tiradeInstVarNames: (in category '*deltastreams-tirade') -----
+ tiradeInstVarNames: assoc
+ self oldVars: assoc key.
+ self instVarNames: assoc value!
Item was added:
+ ----- Method: DSInstVarsChange>>tiradeInstVarNames (in category '*deltastreams-tirade') -----
+ tiradeInstVarNames
+ ^oldVars -> instVarNames!
Item was added:
+ ----- Method: DSClassCommentChange>>tiradeComment: (in category '*deltastreams-tirade') -----
+ tiradeComment: assoc
+ self oldComment: assoc key.
+ self comment: assoc value!
Item was added:
+ ----- Method: DSTiradeReader>>delta:properties: (in category 'tirade') -----
+ delta: uuidString36 properties: properties
+ "Create a new DSDelta from given meta data through Tirade.
+ We put the Delta on the stack for further Tirade messages."
+
+ result := DSDelta new.
+ result uuid: (UUID fromString36: uuidString36); properties: (self arrayOfAssocationsToDictionary: properties).
+ stack add: result.
+ ^result!
Item was added:
+ ----- Method: DSClassChange>>tiradeClassName (in category '*deltastreams-tirade') -----
+ tiradeClassName
+ ^self className!
Item was added:
+ ----- Method: DSClassVarsChange>>tiradeClassVarNames: (in category '*deltastreams-tirade') -----
+ tiradeClassVarNames: assoc
+ self oldVars: assoc key.
+ self classVarNames: assoc value!
Item was changed:
----- Method: DSDelta>>tiradeOn: (in category '*deltastreams-tirade') -----
tiradeOn: recorder
+ "Record this delta using Tirade messages."
+ "First the 'header' holding all meta data of the delta."
+ recorder delta: uuid asString36 properties: properties associations asArray.
+
+ "Then we record all changes recursively. The markers #beginChanges and #endChanges
+ are always there, even if the delta is empty and has no changes."
- recorder delta: uuid asString36 stamp: timeStamp printString properties: properties.
recorder beginChanges.
self changes do: [:each |
each tiradeOn: recorder].
+ recorder endChanges.
+ recorder endDelta!
- recorder endChanges!
Item was added:
+ ----- Method: DSTiradeReader>>upToEnd (in category 'reading') -----
+ upToEnd
+
+ self parse.
+ ^self result!
Item was added:
+ ----- Method: DSClassCommentChange>>tiradeStamp (in category '*deltastreams-tirade') -----
+ tiradeStamp
+ ^oldStamp -> stamp!
Item was added:
+ ----- Method: DSTiradeReader>>sendMessage (in category 'processing') -----
+ sendMessage
+ "Add to composite if we have one."
+
+ lastResult := super sendMessageTo: stack last.
+ composites ifNotEmpty: [composites last add: lastResult]!
Item was added:
+ ----- Method: DSClassChange>>tiradeType: (in category '*deltastreams-tirade') -----
+ tiradeType: value
+ self type: value!
Item was added:
+ ----- Method: DSClassNameChange>>tiradeClassName: (in category '*deltastreams-tirade') -----
+ tiradeClassName: assoc
+ self oldName: assoc key.
+ self className: assoc value!
Item was added:
+ ----- Method: DSClassChange>>tiradeStamp: (in category '*deltastreams-tirade') -----
+ tiradeStamp: value
+ self stamp: value!
Item was added:
+ ----- Method: DSTiradeReader>>endChanges (in category 'tirade') -----
+ endChanges
+ "Remove from stack."
+
+ composites removeLast!
Item was added:
+ ----- Method: DSClassChange>>tiradeClassInstVarNames (in category '*deltastreams-tirade') -----
+ tiradeClassInstVarNames
+ ^self classInstVarNames!
Item was added:
+ ----- Method: DSMethodChange>>tiradeStamp: (in category '*deltastreams-tirade') -----
+ tiradeStamp: value
+ stamp := value!
Item was added:
+ ----- Method: DSCompositeClassDeletedChange>>tiradeOn: (in category '*deltastreams-tirade') -----
+ tiradeOn: recorder
+
+ self compositeDeleteProperties: properties.
+ recorder beginComposite.
+ self changes do: [:each |
+ each tiradeOn: recorder].
+ recorder endComposite!
Item was added:
+ ----- Method: DSDelta>>method:change:category:source:stamp:properties: (in category '*deltastreams-tirade') -----
+ method: classNameAndSelector
+ change: changeClassName
+ category: category
+ source: source
+ stamp: stamp
+ properties: aDictionary
+ "Create and return a method change.
+ It is not added to this Delta."
+
+ ^((self getClass: changeClassName)
+ tiradeClassName: classNameAndSelector key
+ selector: classNameAndSelector value
+ category: category
+ source: source
+ stamp: stamp)
+ properties: aDictionary!
Item was added:
+ ----- Method: DSClassNameChange>>tiradeClassName (in category '*deltastreams-tirade') -----
+ tiradeClassName
+ ^self oldName -> self className !
Item was added:
+ ----- Method: DSMethodChange>>tiradeSource: (in category '*deltastreams-tirade') -----
+ tiradeSource: value
+ source := value!
Item was added:
+ ----- Method: DSClassChange>>tiradeClassName: (in category '*deltastreams-tirade') -----
+ tiradeClassName: value
+ self className: value!
Item was added:
+ ----- Method: DSClassSuperclassChange>>tiradeSuperclassName (in category '*deltastreams-tirade') -----
+ tiradeSuperclassName
+ ^oldSuperclassName -> superclassName!
Item was added:
+ ----- Method: DSClassChange>>tiradeCategory: (in category '*deltastreams-tirade') -----
+ tiradeCategory: value
+ self category: value!
Item was added:
+ ----- Method: DSCompositeClassChange>>endChanges (in category '*deltastreams-tirade') -----
+ endChanges
+ "Return nil causing this object to be removed
+ from the Tirade receiver stack."
+
+ ^nil!
Item was added:
+ ----- Method: DSCompositeClassAddedChange>>tiradeOn: (in category '*deltastreams-tirade') -----
+ tiradeOn: recorder
+
+ recorder compositeAddProperties: properties.
+ recorder beginComposite.
+ self changes do: [:each |
+ each tiradeOn: recorder].
+ recorder endComposite.!
Item was added:
+ ----- Method: DSClassChange>>tiradeClassVarNames (in category '*deltastreams-tirade') -----
+ tiradeClassVarNames
+ ^self classVarNames!
Item was added:
+ ----- Method: DSMethodSelectorChange>>tiradeSelector: (in category '*deltastreams-tirade') -----
+ tiradeSelector: assoc
+ self oldSelector: assoc key;
+ selector: assoc value!
Item was added:
+ ----- Method: DSClassChange>>tiradeComment: (in category '*deltastreams-tirade') -----
+ tiradeComment: value
+ self comment: value!
Item was added:
+ ----- Method: DSDelta>>compositeDeleteProperties: (in category '*deltastreams-tirade') -----
+ compositeDeleteProperties: aDictionary
+ "Create and add change in this Delta."
+
+ ^self add: (
+ DSCompositeClassDeletedChange new
+ properties: aDictionary)!
Item was added:
+ ----- Method: DSClassInstVarsChange>>tiradeClassInstVarNames (in category '*deltastreams-tirade') -----
+ tiradeClassInstVarNames
+ ^oldVars -> classInstVarNames!
Item was added:
+ ----- Method: DSMethodSelectorChange>>tiradeSelector (in category '*deltastreams-tirade') -----
+ tiradeSelector
+ ^oldSelector -> selector!
Item was added:
+ ----- Method: DSClassChange>>tiradePoolDictionaryNames (in category '*deltastreams-tirade') -----
+ tiradePoolDictionaryNames
+ ^self poolDictionaryNames!
Item was added:
+ ----- Method: DSMethodChange>>tiradeSelector (in category '*deltastreams-tirade') -----
+ tiradeSelector
+ ^selector!
Item was added:
+ ----- Method: DSTiradeReader>>endDelta (in category 'tirade') -----
+ endDelta
+ "Delta is done. Collect it if we have a collection set up."
+
+ deltas ifNotNil: [deltas add: result]!
Item was added:
+ ----- Method: DSDelta>>class:change:superclassName:instVarNames:classVarNames:poolDictionaryNames:category:type:classInstVarNames:comment:stamp:properties: (in category '*deltastreams-tirade') -----
+ class: className
+ change: changeName
+ superclassName: superclassName
+ instVarNames: instVarNames
+ classVarNames: classVarNames
+ poolDictionaryNames: poolDictionaryNames
+ category: category
+ type: typeOfClass
+ classInstVarNames: classInstVarNames
+ comment: comment
+ stamp: stamp
+ properties: aDictionary
+ "Create and add change in this Delta.
+ It is not added to this Delta."
+
+ ^((self getClass: changeName)
+ tiradeClassName: className
+ superclassName: superclassName
+ instVarNames: instVarNames
+ classVarNames: classVarNames
+ poolDictionaryNames: poolDictionaryNames
+ category: category
+ type: typeOfClass
+ classInstVarNames: classInstVarNames
+ comment: comment
+ stamp: stamp)
+ properties: aDictionary!
Item was added:
+ ----- Method: DSClassChange>>tiradeStamp (in category '*deltastreams-tirade') -----
+ tiradeStamp
+ ^self stamp!
Item was added:
+ ----- Method: DSClassVarsChange>>tiradeClassVarNames (in category '*deltastreams-tirade') -----
+ tiradeClassVarNames
+ ^oldVars -> classVarNames!
Item was added:
+ ----- Method: DSMethodChange>>tiradeSource (in category '*deltastreams-tirade') -----
+ tiradeSource
+ ^source!
Item was added:
+ ----- Method: DSTiradeReader>>beginChanges (in category 'tirade') -----
+ beginChanges
+ "Upcoming messages will create changes that we need to put into
+ the previous composite change."
+
+ composites add: lastResult!
Item was added:
+ ----- Method: DSClassChange>>tiradeSuperclassName (in category '*deltastreams-tirade') -----
+ tiradeSuperclassName
+ ^self superclassName!
Item was added:
+ ----- Method: DSClassCommentChange>>tiradeComment (in category '*deltastreams-tirade') -----
+ tiradeComment
+ ^oldComment -> comment!
Item was added:
+ ----- Method: DSMethodChange>>tiradeStamp (in category '*deltastreams-tirade') -----
+ tiradeStamp
+ ^stamp!
Item was added:
+ ----- Method: DSClassChange>>tiradeCategory (in category '*deltastreams-tirade') -----
+ tiradeCategory
+ ^self category!
Item was changed:
----- Method: DSChange>>tiradeOn: (in category '*deltastreams-tirade') -----
+ tiradeOn: recorder
+ self subclassResponsibility !
- tiradeOn: recorder!
Item was added:
+ ----- Method: DSDelta>>compositeAddProperties: (in category '*deltastreams-tirade') -----
+ compositeAddProperties: aDictionary
+ "Create and add change in this Delta."
+
+ ^self add: (
+ DSCompositeClassAddedChange new
+ properties: aDictionary)!
Item was added:
+ ----- Method: DSMethodChange>>tiradeCategory (in category '*deltastreams-tirade') -----
+ tiradeCategory
+ ^protocol!
Item was added:
+ ----- Method: DSTiradeReader>>next (in category 'reading') -----
+ next
+ "Consume Tirade messages until we have a single delta."
+
+ [deltas size > 0] whileFalse: [super next].
+ ^deltas first!
Item was added:
+ ----- Method: DSMethodSourceChange>>tiradeStamp: (in category '*deltastreams-tirade') -----
+ tiradeStamp: assoc
+ self oldStamp: assoc key;
+ stamp: assoc value!
Item was added:
+ ----- Method: DSClassCategoryChange>>tiradeCategory (in category '*deltastreams-tirade') -----
+ tiradeCategory
+ ^oldCategory -> category!
Item was removed:
- ----- Method: DSTiradeReader>>delta:stamp:properties: (in category 'tirade') -----
- delta: uuidString36 stamp: timeStampString properties: properties
-
- result := DSDelta new.
- result uuid: (UUID fromString36: uuidString36); properties: properties; timeStamp: (TimeStamp fromString: timeStampString)!
Item was removed:
- ----- Method: DSTiradeReader>>addSelector:class:meta:source:protocol:stamp:at:properties: (in category 'reading') -----
- addSelector: aSelector
- class: className
- meta: meta
- source: source
- protocol: protocol
- stamp: stamp
- at: timeStamp
- properties: properties
-
- result !
Item was removed:
- ----- Method: DSMethodAddedChange>>tiradeOn: (in category '*deltastreams-tirade') -----
- tiradeOn: recorder
- recorder
- addSelector: selector
- class: className
- meta: meta
- source: source
- protocol: protocol
- stamp: stamp
- at: timeStamp printString
- properties: properties!
1
0