[Pkg] DeltaStreams: Traits-gk.234.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Fri Sep 4 09:58:52 UTC 2009
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!
More information about the Packages
mailing list