[Pkg] The Trunk: Traits-ar.256.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Dec 31 13:18:05 UTC 2009
Andreas Raab uploaded a new version of Traits to project The Trunk:
http://source.squeak.org/trunk/Traits-ar.256.mcz
==================== Summary ====================
Name: Traits-ar.256
Author: ar
Time: 29 December 2009, 5:43:46 am
UUID: 6e5471eb-2e9d-2543-91e7-f925aa658271
Ancestors: Traits-ar.255
Shipping NanoTraits part 4: Here comes the big clean up. Let's see if it's loadable :-)
=============== Diff against Traits-ar.255 ===============
Item was changed:
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'!
SystemOrganization addCategory: #'Traits-NanoKernel'!
Item was changed:
----- Method: ClassDescription>>setTraitComposition: (in category '*Traits-NanoKernel') -----
setTraitComposition: aTraitComposition
"OBSOLETE. Use Class uses: aTraitComposition instead."
+ ^self uses: aTraitComposition
+ !
- (aTraitComposition isKindOf: NanoTraitComposition)
- ifTrue:[^self uses: aTraitComposition].
- (aTraitComposition isKindOf: TraitComposition)
- ifTrue:[^super setTraitComposition: aTraitComposition].
- "Unspecified. Check for prevailing traitOverride"
- ClassDescription traitImpl == NanoTrait
- ifTrue:[^self uses: aTraitComposition]
- ifFalse:[^super setTraitComposition: aTraitComposition].!
Item was changed:
----- Method: ClassDescription>>setTraitCompositionFrom: (in category '*Traits-NanoKernel') -----
setTraitCompositionFrom: aTraitComposition
"OBSOLETE. Use Class uses: aTraitComposition instead."
+ ^self uses: aTraitComposition
+ !
- (aTraitComposition isKindOf: NanoTraitComposition)
- ifTrue:[^self uses: aTraitComposition].
- (aTraitComposition isKindOf: TraitComposition)
- ifTrue:[^super setTraitCompositionFrom: aTraitComposition].
- "Unspecified. Check for prevailing traitOverride"
- ClassDescription traitImpl == NanoTrait
- ifTrue:[^self uses: aTraitComposition]
- ifFalse:[^super setTraitCompositionFrom: aTraitComposition].!
Item was changed:
----- Method: ClassDescription>>includesLocalSelector: (in category '*Traits-NanoKernel') -----
includesLocalSelector: selector
+ ^(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self!
- self traitComposition isEmpty "guard for Berne traits"
- ifTrue:[^self includesSelector: selector].
- ^(self traitComposition isKindOf: NanoTraitComposition)
- ifTrue:[(self compiledMethodAt: selector ifAbsent:[^false]) methodHome == self]
- ifFalse:[super includesLocalSelector: selector].!
Item was changed:
----- Method: NanoTrait class>>install (in category 'installing') -----
install "NanoTrait install"
"Installs NanoTraits"
"Force recompilation of basic classes to get traits aliasing right"
{Behavior. ClassDescription. Class. Metaclass} do:[:aClass|
aClass selectorsDo:[:sel|
aClass
compile: (aClass sourceCodeAt: sel)
classified: (aClass organization categoryOfElement: sel)
withStamp: (aClass compiledMethodAt: sel) timeStamp
notifying: nil].
aClass setTraitCompositionFrom: {}].
ClassDescription traitImpl: self. "Create all new traits as NanoTraits"
self updateTraits: Smalltalk allTraits. "And convert everything to NanoTraits"
Smalltalk allClassesAndTraitsDo:[:aClass|
aClass traitComposition isEmpty
ifTrue:[aClass traitComposition: nil].
aClass classSide traitComposition isEmpty
ifTrue:[aClass classSide traitComposition: nil]].
"TWriteStreamTest has the class traits reversed which which will be undone
by installation. Put it back in reverse order to keep MC happy."
+ (Smalltalk at: #TWriteStreamTest) classTrait
+ uses:
+ (Smalltalk at: #TSequencedStreamTest) classTrait +
+ (Smalltalk at: #TPuttableStreamTest) classTrait.
- TWriteStreamTest classTrait
- uses: TSequencedStreamTest classTrait + TPuttableStreamTest classTrait
!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: LocatedMethod class>>location:selector: (in category 'instance creation') -----
- location: aPureBehavior selector: aSymbol
- ^self new
- location: aPureBehavior selector: aSymbol;
- yourself!
Item was removed:
- ----- 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
-
- !
Item was removed:
- ----- Method: TraitDescription>>hasClassTrait (in category 'accessing parallel hierarchy') -----
- hasClassTrait
- self subclassResponsibility!
Item was removed:
- ----- Method: TraitsResource>>isDirty (in category 'accessing') -----
- isDirty
- ^dirty!
Item was removed:
- ----- Method: ClassTrait>>classTrait (in category 'accessing parallel hierarchy') -----
- classTrait
- ^self!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendInfo>>doPop (in category 'instruction decoding') -----
- doPop
-
- stack isEmpty ifFalse: [self pop]!
Item was removed:
- ----- Method: TraitBehavior>>subclasses (in category 'class compatibility') -----
- subclasses
- ^ Array new!
Item was removed:
- ----- Method: TraitBehavior>>users (in category 'traits') -----
- users
- ^users!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TCompilingBehavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') -----
- addSelector: selector withMethod: compiledMethod notifying: requestor
- ^ self addSelectorSilently: selector withMethod: compiledMethod!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: QuickStack>>last (in category 'accessing') -----
- last
- ^self at: top!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TCompilingBehavior>>removeSelectorSilently: (in category 'adding/removing methods') -----
- removeSelectorSilently: selector
- "Remove selector without sending system change notifications"
-
- ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].!
Item was removed:
- ----- 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]]
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitDescription>>spaceUsed (in category 'private') -----
- spaceUsed
- ^super spaceUsed + (self hasClassTrait
- ifTrue: [self classTrait spaceUsed]
- ifFalse: [0])!
Item was removed:
- ----- Method: TimeMeasuringTest>>versionInformation (in category 'as yet unclassified') -----
- versionInformation
- | wcPredicate |
- wcPredicate := self workingCopyPredicate.
- ^self versionInfoForWorkingCopiesThat: wcPredicate!
Item was removed:
- ----- Method: SendInfo>>top (in category 'stack manipulation') -----
- top
- ^ stack last!
Item was removed:
- Collection variableSubclass: #FixedIdentitySet
- instanceVariableNames: 'tally capacity hashShift'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Requires'!
-
- !FixedIdentitySet commentStamp: 'nice 12/24/2009 11:46' prior: 0!
- This is a fast implementation of fixed size identity sets.
- Same algorithm as MethodDictionary are used, and thus FixedIdentitySet is to IdentitySet what MethodDictionary is to IdentityDictionary.
- The main features are:
- 1) do not use an array instance variable so as to fast-up creation and every access
- 2) due to the fixed allocated size, growing costs an expensive #become: operation. Preallocate me with care.
- 3) my size is a power of two so the the hashing algorithm be most efficient.
- 4) for maximum random access efficiency, at least half the storage area is always kept empty
-
- Unlike MethodDictionary, this class will scale a bit better over the 4096 basicSize limit inherent to identityHash, thanks to a proper bitShift.!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>rootClasses (in category 'accessing') -----
- rootClasses
- ^rootClasses!
Item was removed:
- ----- Method: FixedIdentitySet>>capacity (in category 'accessing') -----
- capacity
- ^ capacity!
Item was removed:
- TraitsTestCase subclass: #SystemTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: TAccessingTraitCompositionBehavior>>removeAlias:of: (in category 'traits') -----
- removeAlias: aSymbol of: aTrait
- self setTraitComposition: (
- self traitComposition copyWithoutAlias: aSymbol of: aTrait)!
Item was removed:
- ----- Method: SendCaches>>superSentSelectorsAndSendersDo: (in category 'accessing-specific') -----
- superSentSelectorsAndSendersDo: aBlock
- superSenders keysAndValuesDo: aBlock!
Item was removed:
- ----- Method: Trait>>environment: (in category 'accessing') -----
- environment: anObject
- environment := anObject!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>rootClasses: (in category 'accessing') -----
- rootClasses: anObject
- rootClasses := anObject!
Item was removed:
- ----- Method: FixedIdentitySet>>removeAll (in category 'removing') -----
- removeAll
- tally = 0 ifTrue: [^self].
- 1 to: self basicSize do: [:i | self basicAt: i put: nil].
- tally := 0!
Item was removed:
- ----- Method: Trait>>isClassTrait (in category 'accessing parallel hierarchy') -----
- isClassTrait
- ^false!
Item was removed:
- 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'!
Item was removed:
- ----- Method: TCompilingBehavior>>addSelector:withMethod: (in category 'adding/removing methods') -----
- addSelector: selector withMethod: compiledMethod
- ^ self addSelector: selector withMethod: compiledMethod notifying: nil!
Item was removed:
- ----- Method: TComposingDescription>>@ (in category 'composition') -----
- @ anArrayOfAssociations
- ^ TraitAlias with: self aliases: anArrayOfAssociations!
Item was removed:
- ----- Method: TPureBehavior>>traitComposition: (in category 'traits') -----
- traitComposition: aTraitComposition
- ^self explicitRequirement !
Item was removed:
- ----- 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: $].!
Item was removed:
- ----- Method: SendInfo>>pushConstant: (in category 'instruction decoding') -----
- pushConstant: value
-
- self push: value!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitBehavior>>basicLocalSelectors: (in category 'accessing method dictionary') -----
- basicLocalSelectors: aSetOrNil
- localSelectors := aSetOrNil!
Item was removed:
- ----- Method: ClassTrait>>name (in category 'accessing') -----
- name
- ^self baseTrait name , ' classTrait'!
Item was removed:
- ----- Method: QuickStack>>size (in category 'accessing') -----
- size
- ^ top!
Item was removed:
- ----- Method: LocatedMethod>>selector (in category 'accessing') -----
- selector
- ^selector!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TPureBehavior>>methodDict (in category 'accessing method dictionary') -----
- methodDict
- ^ self explicitRequirement!
Item was removed:
- ----- Method: QuickStack>>isEmpty (in category 'accessing') -----
- isEmpty
- ^ top = 0!
Item was removed:
- ----- Method: TraitsResource>>c4: (in category 'accessing') -----
- c4: anObject
- ^c4 := anObject!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>findAffectedTraitsFrom: (in category 'calculating') -----
- findAffectedTraitsFrom: targetTraitsCollection
- traitsToUpdate := targetTraitsCollection
- select: [:t | modifiedBehaviors anySatisfy: [:mb | t traitCompositionIncludes: mb]]!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>findRootsAndRoutes (in category 'calculating') -----
- findRootsAndRoutes
- "Based on the
- 1. target classes (ones considered interesting by our clients) and the
- 2. modifiedBehaviors (ones we are told might have changed),
- decide the
- A. rootClasses (superclasses of target classes that include methods from modifiedBehaviors)
- B. classesToUpdate (classes that may have been affected AND are on an inheritance path between a root class and a target class, will be updated by the algorithm. This includes the every target class that may have been affected).
- C. mapping from root classes to its classesToUpdate."
-
- | modifiedClasses |
- classesToUpdate := IdentitySet new.
- rootClasses := IdentitySet new.
- modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet.
- targetClasses do: [:currentTargetClass | | highestSuperclassOfCurrentTarget |
- highestSuperclassOfCurrentTarget := nil.
- currentTargetClass withAllSuperclassesDo: [:sc |
- (modifiedClasses includes: sc) ifTrue:
- [highestSuperclassOfCurrentTarget := sc.
- self noteRoot: sc possiblyAffected: currentTargetClass]].
- highestSuperclassOfCurrentTarget ifNotNil: [:highestRoot |
- self addUpdatePathTo: currentTargetClass from: highestRoot]]!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: TCompilingBehavior>>selectors (in category 'accessing method dictionary') -----
- selectors
- "Answer a collection of all the message selectors specified in the receiver's
- method dictionary."
-
- ^ self methodDict keys!
Item was removed:
- ----- 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].!
Item was removed:
- ----- Method: TCompilingBehavior>>compileAll (in category 'compiling') -----
- compileAll
- ^ self compileAllFrom: self!
Item was removed:
- ----- Method: TPureBehavior>>hasTraitComposition (in category 'traits') -----
- hasTraitComposition
- self explicitRequirement!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: TFileInOutDescription>>printCategoryChunk:withStamp:on: (in category 'fileIn/Out') -----
- printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream
- ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp
- priorMethod: nil!
Item was removed:
- ----- Method: RequiresTestCase>>selfSentSelectorsInTrait:fromSelectors: (in category 'as yet unclassified') -----
- selfSentSelectorsInTrait: composedTrait fromSelectors: interestingSelectors
- ^composedTrait selfSentSelectorsFromSelectors: interestingSelectors
- !
Item was removed:
- ----- Method: TraitBehavior>>allSuperclasses (in category 'class compatibility') -----
- allSuperclasses
- ^ OrderedCollection new!
Item was removed:
- ----- Method: RequiresTestCase>>updateRequiredStatusFor:in: (in category 'as yet unclassified') -----
- updateRequiredStatusFor: selector in: aClass
- self class updateRequiredStatusFor: selector in: aClass
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendCaches>>classSentSelectorsAndSendersDo: (in category 'accessing-specific') -----
- classSentSelectorsAndSendersDo: aBlock
- classSenders keysAndValuesDo: aBlock!
Item was removed:
- ----- 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).
- !
Item was removed:
- ----- Method: TraitsTestCase>>c1 (in category 'accessing') -----
- c1
- ^TraitsResource current c1!
Item was removed:
- ----- Method: RequiresTestCase>>requiredMethodsForTrait: (in category 'as yet unclassified') -----
- requiredMethodsForTrait: aTrait
- ^aTrait requiredSelectors!
Item was removed:
- ----- Method: ModelExtension>>noteInterestOf:in: (in category 'interests') -----
- noteInterestOf: client in: class
- self noteInterestOf: client inAll: {class}!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: Trait>>environment (in category 'accessing') -----
- environment
- ^environment!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitBehavior>>allSelectors (in category 'accessing method dictionary') -----
- allSelectors
- ^ self selectors asSet!
Item was removed:
- ----- Method: TraitsResource>>t4: (in category 'accessing') -----
- t4: anObject
- ^t4 := anObject!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>prepareAllCaches (in category 'as yet unclassified') -----
- prepareAllCaches
- self subclassResponsibility.!
Item was removed:
- ----- 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
- }!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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].
- ].
- !
Item was removed:
- ----- 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])]].!
Item was removed:
- ----- Method: SendCaches>>selfSenders (in category 'accessing') -----
- selfSenders
- ^selfSenders!
Item was removed:
- ----- Method: TComposingDescription>>addOnTheLeft: (in category 'private') -----
- addOnTheLeft: aTraitExpression
- ^TraitComposition with: aTraitExpression with: self!
Item was removed:
- ----- 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: ))!
Item was removed:
- ----- 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]!
Item was removed:
- TraitsTestCase subclass: #TraitCompositionTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: TraitsResource>>c8: (in category 'accessing') -----
- c8: anObject
- ^c8 := anObject!
Item was removed:
- ----- Method: Trait>>baseTrait (in category 'accessing parallel hierarchy') -----
- baseTrait
- ^self!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: FixedIdentitySet>>add: (in category 'adding') -----
- add: anObject
- | index |
- index := self scanFor: anObject.
- (self basicAt: index)
- ifNil: [
- self basicAt: index put: anObject.
- tally := tally + 1.
- self isFull ifTrue: [ self grow ]]
- "ifNotNil: [] already inside".
- ^anObject!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: FixedIdentitySet>>addAll:notIn: (in category 'adding') -----
- addAll: aCollection notIn: notCollection
- aCollection do: [:each |
- (notCollection includes: each) ifFalse: [self add: each].
- ].!
Item was removed:
- ----- Method: TPureBehavior>>canZapMethodDictionary (in category 'testing') -----
- canZapMethodDictionary
- "Return true if it is safe to zap the method dictionary on #obsolete"
- ^true!
Item was removed:
- ----- Method: RequiredSelectors>>newCacheFor: (in category 'access to cache') -----
- newCacheFor: aClass
- ^RequirementsCache new!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SendCaches>>addSuperSender:of: (in category 'updates') -----
- addSuperSender: sendingSelector of: sentSelector
- | senders |
- senders := superSenders at: sentSelector ifAbsent: [#()].
- superSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was removed:
- ----- Method: TTraitsCategorisingDescription>>noteRecategorizedSelectors:oldComposition: (in category 'organization updating') -----
- noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition
-
- aCollection do: [:each | | oldCategory newCategory |
- oldCategory := self organization categoryOfElement: each.
- newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory.
- self noteRecategorizedSelector: each from: oldCategory to: newCategory]!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>selectorsToUpdateIn: (in category 'calculating') -----
- selectorsToUpdateIn: aClass
- ^originalSinsPerSelector keys
- !
Item was removed:
- 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'!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: ModelExtension>>lostInterest:in: (in category 'interests') -----
- lostInterest: client in: class
- self lostInterest: client inAll: {class}!
Item was removed:
- ----- 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]]
- !
Item was removed:
- ----- Method: TraitsResource>>c3 (in category 'accessing') -----
- c3
- ^c3!
Item was removed:
- ----- Method: TraitDescription>>version (in category 'accessing') -----
- version
- "Allows polymoprhism with ClassDescription>>version"
-
- ^ self traitVersion!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsTestCase>>c5 (in category 'accessing') -----
- c5
- ^TraitsResource current c5!
Item was removed:
- ----- Method: TFileInOutDescription>>fileOutChangedMessages:on:moveSource:toFile: (in category 'fileIn/Out') -----
- fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex
- "File a description of the messages of this class that have been
- changed (i.e., are entered into the argument, aSet) onto aFileStream. If
- moveSource, is true, then set the method source pointer to the new file position.
- Note when this method is called with moveSource=true, it is condensing the
- .changes file, and should only write a preamble for every method."
- | org |
- (org := self organization) categories do:
- [:cat | | sels |
- 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 removed:
- ----- Method: TFileInOutDescription>>fileOutOn: (in category 'fileIn/Out') -----
- fileOutOn: aFileStream
- "File a description of the receiver on aFileStream."
-
- self fileOutOn: aFileStream
- moveSource: false
- toFile: 0!
Item was removed:
- ----- Method: TraitsResource>>t2 (in category 'accessing') -----
- t2
- ^t2!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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)).
- !
Item was removed:
- ----- Method: SendCaches>>superSendersOf: (in category 'accessing-specific') -----
- superSendersOf: selector
- ^ superSenders at: selector ifAbsent: [#()].!
Item was removed:
- ----- Method: TraitBehavior>>allClassVarNames (in category 'class compatibility') -----
- allClassVarNames
- ^#()!
Item was removed:
- ----- Method: TraitsTestCase>>t4 (in category 'accessing') -----
- t4
- ^TraitsResource current t4!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: TraitBehavior>>allSubclassesDo: (in category 'class compatibility') -----
- allSubclassesDo: aBlock!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>categoryName (in category 'as yet unclassified') -----
- categoryName
- ^self class category!
Item was removed:
- ----- 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: ''.!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>classesToUpdate: (in category 'accessing') -----
- classesToUpdate: anObject
- classesToUpdate := anObject!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: TPrintingDescription>>printOnStream: (in category 'printing') -----
- printOnStream: aStream
- aStream print: self name!
Item was removed:
- ----- Method: ModelExtension>>haveInterestsIn: (in category 'access to cache') -----
- haveInterestsIn: aClass
- lock critical: [^interests includes: aClass]
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>modifiedBehaviors: (in category 'accessing') -----
- modifiedBehaviors: anObject
- modifiedBehaviors := anObject!
Item was removed:
- ----- Method: TraitBehavior>>allInstVarNames (in category 'class compatibility') -----
- allInstVarNames
- ^ #()!
Item was removed:
- ----- Method: TraitsTestCase class>>resources (in category 'as yet unclassified') -----
- resources
- ^{TraitsResource}!
Item was removed:
- ----- Method: TraitsResource class>>resetIfDirty (in category 'as yet unclassified') -----
- resetIfDirty
- self current isDirty ifTrue: [self reset]!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>possiblyAffectedForRoot: (in category 'calculating') -----
- possiblyAffectedForRoot: rootClass
- ^possiblyAffectedPerRoot at: rootClass ifAbsentPut: [IdentitySet new].!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>classesInCategories: (in category 'as yet unclassified') -----
- classesInCategories: currentCats
- ^currentCats gather:
- [:c |
- (SystemOrganization listAtCategoryNamed: c)
- collect: [:name | Smalltalk at: name]]!
Item was removed:
- ----- Method: TraitBehavior>>sendCaches (in category 'send caches') -----
- sendCaches
- ^LocalSends current for: self!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendInfo>>pushReceiverVariable: (in category 'instruction decoding') -----
- pushReceiverVariable: anOffset
- "Push the value of one of the receiver's instance variables."
-
- self push: #stuff.!
Item was removed:
- ----- Method: TraitBehavior>>allSubclasses (in category 'class compatibility') -----
- allSubclasses
- ^ Array new!
Item was removed:
- ----- Method: TimeMeasuringTest>>measure: (in category 'as yet unclassified') -----
- measure: measuredBlock
- shouldProfile
- ifTrue: [TimeProfileBrowser onBlock: [10 timesRepeat: measuredBlock]].
- realTime := measuredBlock timeToRun!
Item was removed:
- ----- Method: ClassTrait>>initializeFrom: (in category 'initialize') -----
- initializeFrom: anotherClassTrait
- traitComposition := self traitComposition copyTraitExpression.
- methodDict := self methodDict copy.
- localSelectors := self localSelectors copy.
- organization := self organization copy.!
Item was removed:
- ----- Method: TCompilingBehavior>>hasMethods (in category 'testing method dictionary') -----
- hasMethods
- "Answer whether the receiver has any methods in its method dictionary."
-
- ^ self methodDict size > 0!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>c7 (in category 'accessing') -----
- c7
- ^c7!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendCaches>>initialize (in category 'accessing') -----
- initialize
- selfSenders := IdentityDictionary new.
- superSenders := IdentityDictionary new.
- classSenders := IdentityDictionary new.!
Item was removed:
- ----- Method: Behavior>>withInheritanceTraitCompositionIncludes: (in category '*Traits-requires') -----
- withInheritanceTraitCompositionIncludes: aTrait
- ^self withAllSuperclasses anySatisfy: [:c | c traitCompositionIncludes: aTrait]!
Item was removed:
- ----- Method: SendsInfoTest>>testClassBranch (in category 'tests') -----
- testClassBranch
- self assert: #classBranch sends: #(tell shouldnt:raise:) supersends: #() classSends: #(tell).
- self classBranch.!
Item was removed:
- ----- 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 ))!
Item was removed:
- ----- Method: SendInfo>>doDup (in category 'instruction decoding') -----
- doDup
- "Simulate the action of a 'duplicate top of stack' bytecode."
-
- self push: self top!
Item was removed:
- ----- Method: TFileInOutDescription>>definition (in category 'fileIn/Out') -----
- definition
- "Answer a String that defines the receiver in good old ST-80."
-
- ^ self definitionST80!
Item was removed:
- ----- Method: Trait>>obsolete (in category 'initialize-release') -----
- obsolete
- self name: ('AnObsolete' , self name) asSymbol.
- self hasClassTrait ifTrue: [
- self classTrait obsolete].
- super obsolete!
Item was removed:
- ----- 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."
- !
Item was removed:
- ----- Method: TPureBehavior>>sendCaches: (in category 'send caches') -----
- sendCaches: aSendCaches
- ^ self explicitRequirement!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: TraitsResource>>t6 (in category 'accessing') -----
- t6
- ^t6!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>targetBehaviors (in category 'accessing') -----
- targetBehaviors
- ^targetBehaviors!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- Method: RequirementsCache>>addRequirement: (in category 'updates') -----
- addRequirement: selector
- requirements ifNil: [requirements := self newRequirementsObject].
- requirements add: selector.!
Item was removed:
- ----- Method: TPureBehavior>>isProvidedSelector: (in category 'testing method dictionary') -----
- isProvidedSelector: selector
- ^ ProvidedSelectors current isSelector: selector providedIn: self
- !
Item was removed:
- ----- Method: CodeModelExtension>>initialize (in category 'access to cache') -----
- initialize
- super initialize.
- perClassCache := IdentityDictionary new.!
Item was removed:
- TraitsTestCase subclass: #TraitMethodDescriptionTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- 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.!
Item was removed:
- ----- Method: TTraitsCategorisingDescription>>applyChangesOfNewTraitCompositionReplacing: (in category 'organization updating') -----
- applyChangesOfNewTraitCompositionReplacing: oldComposition
- | changedSelectors |
- changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition.
- self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition.
- ^ changedSelectors.!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TraitsResource>>c2: (in category 'accessing') -----
- c2: anObject
- ^c2 := anObject!
Item was removed:
- ----- Method: TraitDescription>>isClassTrait (in category 'accessing parallel hierarchy') -----
- isClassTrait
- self subclassResponsibility!
Item was removed:
- ----- Method: SendInfo>>home (in category 'accessing') -----
- home
- "Answer the context in which the receiver was defined."
-
- ^ sender!
Item was removed:
- ----- Method: Trait class>>named:uses:category: (in category 'instance creation') -----
- named: aSymbol uses: aTraitCompositionOrCollection category: aString
- "Dispatch through ClassDescription for alternative implementations"
- ^ClassDescription newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString!
Item was removed:
- ----- 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 |
- (aString isKindOf: RemoteString) ifTrue:
- [SystemChangeNotifier uniqueInstance classCommented: self.
- ^ 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 classCommented: self.
- !
Item was removed:
- ----- Method: SendInfo>>atMergePoint (in category 'stack manipulation') -----
- atMergePoint
- ^ savedStacks includesKey: pc!
Item was removed:
- ----- 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.!
Item was removed:
- ModelExtension subclass: #CodeModelExtension
- instanceVariableNames: 'perClassCache'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-LocalSends'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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: 5)
- add: firstObject;
- add: secondObject;
- add: thirdObject;
- add: fourthObject;
- add: fifthObject;
- yourself!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn:ifIn: (in category 'calculating') -----
- removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass ifIn: rootsHandledBySel
- oldRequiredSelectorsByClass keysAndValuesDo:
- [:class :oldRequirements |
- | cache newRequirements unconfirmedRequirements |
- newRequirements := requiredSelectorsByClass at: class
- ifAbsent: [#()].
- cache := class requiredSelectorsCache.
- unconfirmedRequirements := oldRequirements copyWithoutAll: newRequirements.
- unconfirmedRequirements do: [:sel |
- | roots |
- roots := rootsHandledBySel at: sel ifAbsent: [#()].
- (roots anySatisfy: [:rc |
- | affected |
- affected := possiblyAffectedPerRoot at: rc ifAbsent: #().
- (affected includes: class)]) ifTrue: [cache removeRequirement: sel]]]!
Item was removed:
- ----- Method: ModelExtension>>noteInterestOf:inAll: (in category 'interests') -----
- noteInterestOf: client inAll: classes
- lock critical: [interests addAll: classes].!
Item was removed:
- ----- Method: TraitDescription>>theMetaClass (in category 'class compatibility') -----
- theMetaClass
- ^ self classTrait!
Item was removed:
- ----- Method: ModelExtension class>>initialize (in category 'initialize-release') -----
- initialize
- "Unregister subclasses since we're about to go"
- self withAllSubclassesDo:[:subclass|
- SystemChangeNotifier uniqueInstance noMoreNotificationsFor: subclass.
- SystemChangeNotifier uniqueInstance noMoreNotificationsFor: subclass current.
- ].
- !
Item was removed:
- ----- Method: SendCaches>>selfSentSelectorsAndSendersDo: (in category 'accessing-specific') -----
- selfSentSelectorsAndSendersDo: aBlock
- selfSenders keysAndValuesDo: aBlock!
Item was removed:
- ----- Method: TAccessingTraitCompositionBehavior>>addToComposition: (in category 'traits') -----
- addToComposition: aTrait
- self setTraitComposition: (self traitComposition copyTraitExpression
- add: aTrait;
- yourself)!
Item was removed:
- ----- 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
- !
Item was removed:
- 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.!
Item was removed:
- ----- Method: NanoTrait class>>unloadBerneTraits (in category 'installing') -----
- unloadBerneTraits
- "Unload Berne traits via Monticello"
- #(TraitBehavior TraitDescription ClassTrait) do:[:clsName|
- Smalltalk at: clsName ifPresent:[:aClass| aClass traitComposition: nil]].
-
- "Special for Trait since it becomes a plain old global"
- Smalltalk at: #Trait ifPresent:[:aClass|
- aClass name == #Trait ifTrue:[aClass traitComposition: nil].
- ].
- Smalltalk at: #ModelExtension ifPresent:[:aClass|
- aClass withAllSubclassesDo:[:subclass|
- SystemChangeNotifier uniqueInstance noMoreNotificationsFor: subclass.
- SystemChangeNotifier uniqueInstance noMoreNotificationsFor: subclass current.
- ]].
-
- (MCPackage named: 'Traits') unload.
-
- Smalltalk allClassesDo:[:aClass|
- aClass basicLocalSelectors: nil.
- aClass class basicLocalSelectors: nil.
- aClass traitComposition class isObsolete
- ifTrue:[aClass traitComposition: nil].
- aClass classSide traitComposition class isObsolete
- ifTrue:[aClass classSide traitComposition: nil].
- ].
- !
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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).
-
-
- !
Item was removed:
- ----- Method: FullMERequiresSpeedTestCase>>prepareAllCaches (in category 'as yet unclassified') -----
- prepareAllCaches
- | classes |
- classes := displayedClasses , focusedClasses.
- self noteInterestInClasses: classes.
- self getInformationFor: classes!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>setUp (in category 'as yet unclassified') -----
- setUp
- self decideInterestingClasses.
- !
Item was removed:
- ----- Method: TraitBehavior>>initialize (in category 'initialize-release') -----
- initialize
- self methodDict: MethodDictionary new.
- self traitComposition: nil.
- users := IdentitySet new.!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: TraitsResource>>t2: (in category 'accessing') -----
- t2: anObject
- ^t2 := anObject!
Item was removed:
- TraitsTestCase subclass: #PureBehaviorTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: RequiresSpeedTestCase class>>isAbstract (in category 'as yet unclassified') -----
- isAbstract
- ^self == RequiresSpeedTestCase !
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>traitsToUpdate (in category 'accessing') -----
- traitsToUpdate
- ^traitsToUpdate!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: SendInfo>>emptyStack (in category 'stack manipulation') -----
- emptyStack
- stack removeAll!
Item was removed:
- ----- Method: TCompilingBehavior>>evaluatorClass (in category 'compiling') -----
- evaluatorClass
- "Answer an evaluator class appropriate for evaluating expressions in the
- context of this class."
-
- ^Compiler!
Item was removed:
- ----- Method: RequiredSelectors>>calculateForClass: (in category 'access to cache') -----
- calculateForClass: aClass
- | rscc |
- self clearOut: aClass.
- rscc := RequiredSelectorsChangesCalculator onModificationOf: { aClass }
- withTargets: { aClass }.
- rscc doWork!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendInfo>>method (in category 'accessing') -----
- method
- "Answer the method of this context."
-
- ^ sender!
Item was removed:
- ----- 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."
- !
Item was removed:
- ----- Method: SendInfo>>push: (in category 'stack manipulation') -----
- push: aValue
- stack addLast: aValue.!
Item was removed:
- ----- Method: QuickStack>>setTop: (in category 'private') -----
- setTop: t
- top := t!
Item was removed:
- ----- Method: TCommentDescription>>comment: (in category 'accessing comment') -----
- comment: aStringOrText
- "Set the receiver's comment to be the argument, aStringOrText."
-
- self instanceSide classComment: aStringOrText.!
Item was removed:
- ----- Method: TraitsResource>>c6: (in category 'accessing') -----
- c6: anObject
- ^c6 := anObject!
Item was removed:
- ----- Method: SendCaches>>addSelfSender:of: (in category 'updates') -----
- addSelfSender: sendingSelector of: sentSelector
- | senders |
- senders := selfSenders at: sentSelector ifAbsent: [#()].
- selfSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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).!
Item was removed:
- ----- Method: FixedIdentitySet>>isFull (in category 'testing') -----
- isFull
- ^ tally >= capacity!
Item was removed:
- ----- Method: TraitDescription>>notifyUsersOfChangedSelectors: (in category 'users notification') -----
- notifyUsersOfChangedSelectors: aCollection
- self users do: [:each |
- each noteChangedSelectors: aCollection]!
Item was removed:
- ----- Method: TimeMeasuringTest>>runCase (in category 'as yet unclassified') -----
- runCase
- [super runCase] ensure: [self reportPerformance]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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: '']
- !
Item was removed:
- ----- Method: TCompilingBehavior>>sourceCodeAt: (in category 'accessing method dictionary') -----
- sourceCodeAt: selector
-
- ^ (self methodDict at: selector) getSourceFor: selector in: self!
Item was removed:
- ----- Method: Trait>>isObsolete (in category 'testing') -----
- isObsolete
- "Return true if the receiver is obsolete."
- ^(self environment at: name ifAbsent: [nil]) ~~ self!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>createdClassesAndTraits (in category 'as yet unclassified') -----
- createdClassesAndTraits
- createdClassesAndTraits ifNil: [
- createdClassesAndTraits := OrderedCollection new].
- ^createdClassesAndTraits!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TPureBehavior>>deepCopy (in category 'copying') -----
- deepCopy
- "Classes should only be shallowCopied or made anew."
-
- ^ self shallowCopy!
Item was removed:
- 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.!
Item was removed:
- ----- Method: TPureBehavior>>deregisterLocalSelector: (in category 'accessing method dictionary') -----
- deregisterLocalSelector: aSymbol
- self basicLocalSelectors notNil ifTrue: [
- self basicLocalSelectors remove: aSymbol ifAbsent: []]!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>findOriginalSins (in category 'calculating') -----
- findOriginalSins
- | checkedClasses |
- checkedClasses := IdentitySet new.
- originalSinsPerSelector := IdentityDictionary new.
- rootClasses do:
- [:rootClass |
- rootClass withAllSuperclassesDo: [:superClass |
- | sinnedSelectors |
- (checkedClasses includes: superClass) ifFalse: [
- checkedClasses add: superClass.
- sinnedSelectors := self sinsIn: superClass.
- sinnedSelectors do:
- [:sinSel |
- | sinners |
- sinners := originalSinsPerSelector at: sinSel
- ifAbsentPut: [IdentitySet new].
- sinners add: superClass]]]]!
Item was removed:
- ----- Method: ModelExtension class>>isAbstract (in category 'initialize-release') -----
- isAbstract
- ^self == ModelExtension!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>initialize (in category 'calculating') -----
- initialize
- possiblyAffectedPerRoot := IdentityDictionary new.!
Item was removed:
- ----- Method: ClassTrait>>baseTrait: (in category 'accessing parallel hierarchy') -----
- baseTrait: aTrait
- self assert: aTrait isBaseTrait.
- baseTrait := aTrait
-
- !
Item was removed:
- ----- Method: TraitBehavior>>allSuperclassesDo: (in category 'class compatibility') -----
- allSuperclassesDo: aBlock!
Item was removed:
- ----- 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: 6)
- add: firstObject;
- add: secondObject;
- add: thirdObject;
- add: fourthObject;
- add: fifthObject;
- add: sixthObject;
- yourself!
Item was removed:
- ----- 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] !
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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: "
- !
Item was removed:
- ----- Method: TraitDescription>>category (in category 'organization') -----
- category
- self subclassResponsibility!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- TestCase subclass: #TraitsTestCase
- instanceVariableNames: 'createdClassesAndTraits'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: SendInfo>>pushLiteralVariable: (in category 'instruction decoding') -----
- pushLiteralVariable: value
-
- self push: #stuff!
Item was removed:
- ----- Method: RequiredSelectors>>dirtyClasses (in category 'accessing') -----
- dirtyClasses
- dirtyClasses ifNil: [dirtyClasses := WeakSet new].
- ^dirtyClasses!
Item was removed:
- ----- 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] ifNotNil: [:dict | dict keys].
- sins := negativeDefined union: (selfSent copyWithoutAll: aClass providedSelectors).
- ^sins!
Item was removed:
- ----- 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)!
Item was removed:
- ----- Method: FixedIdentitySet class>>new (in category 'instance creation') -----
- new
- ^ self new: self defaultSize!
Item was removed:
- ----- Method: SendInfo>>method:pc: (in category 'initialization') -----
- method: method pc: initialPC
- super method: method pc: initialPC.
- self prepareState.!
Item was removed:
- ----- Method: CodeModelExtension>>cacheFor: (in category 'access to cache') -----
- cacheFor: aClass
- ^perClassCache at: aClass ifAbsentPut: [self newCacheFor: aClass]!
Item was removed:
- 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.!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: LocatedMethod>>location (in category 'accessing') -----
- location
- ^location!
Item was removed:
- ----- Method: TCompilingBehavior>>methodDictionary (in category 'accessing method dictionary') -----
- methodDictionary
- "Convenience"
- ^self methodDict!
Item was removed:
- Object subclass: #RequirementsCache
- instanceVariableNames: 'requirements superRequirements'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-LocalSends'!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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: #+."!
Item was removed:
- ----- Method: Trait>>classTrait: (in category 'accessing parallel hierarchy') -----
- classTrait: aTrait
- "Assigns the class trait associated with the receiver."
-
- self assert: aTrait isClassTrait.
- classTrait := aTrait!
Item was removed:
- ----- Method: SendCaches>>selfSenders: (in category 'accessing') -----
- selfSenders: anObject
- ^selfSenders := anObject!
Item was removed:
- ----- Method: TPureBehavior>>traitTransformations (in category 'traits') -----
- traitTransformations
- ^ self traitComposition transformations !
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TFileInOutDescription>>methodsFor:stamp: (in category 'fileIn/Out') -----
- methodsFor: categoryName stamp: changeStamp
- ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0!
Item was removed:
- ----- Method: Behavior>>requiredSelectorsCache (in category '*Traits-requires') -----
- requiredSelectorsCache
- ^RequiredSelectors current cacheFor: self!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: ModelExtension class>>current: (in category 'accessing') -----
- current: anObject
- ^current := anObject!
Item was removed:
- ----- 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 !
Item was removed:
- ----- Method: LocatedMethod>>category (in category 'convenience') -----
- category
- ^self location
- whichCategoryIncludesSelector: self selector!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>storeRequirementsUnder:for:in: (in category 'calculating') -----
- storeRequirementsUnder: rc for: selector in: requiredSelectorsByClass
- | requiringClasses |
- requiringClasses := rc updateRequiredStatusFor: selector
- inSubclasses: (self possiblyAffectedForRoot: rc).
- ^requiringClasses do:
- [:requiringClass |
- | selectorsForClass |
- selectorsForClass := requiredSelectorsByClass at: requiringClass
- ifAbsentPut: [IdentitySet new].
- selectorsForClass add: selector]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- 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')
- !
Item was removed:
- ----- 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]]]!
Item was removed:
- TestCase subclass: #TimeMeasuringTest
- instanceVariableNames: 'realTime shouldProfile'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Requires'!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: TPureBehavior>>methodDict: (in category 'accessing method dictionary') -----
- methodDict: aDictionary
- ^ self explicitRequirement!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: ClassTrait>>isBaseTrait (in category 'accessing parallel hierarchy') -----
- isBaseTrait
- ^false!
Item was removed:
- ----- Method: SystemTest>>testClassFromPattern (in category 'testing') -----
- testClassFromPattern
- "self debug: #testClassFromPattern"
-
- self assert: (Utilities classFromPattern: 'TCompilingB' withCaption: '') = TCompilingBehavior!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TCompilingBehavior>>spaceUsed (in category 'private') -----
- spaceUsed
- "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."
-
- | space |
- space := 0.
- self selectorsDo: [:sel | | method |
- space := space + 16. "dict and org'n space"
- method := self compiledMethodAt: sel.
- space := space + (method size + 6 "hdr + avg pad").
- method literals do: [:lit |
- (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)].
- (lit isMemberOf: Float) ifTrue: [space := space + 12].
- (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)].
- (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)].
- (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]].
- ^ space!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- Method: TraitsResource>>t5: (in category 'accessing') -----
- t5: anObject
- ^t5 := anObject!
Item was removed:
- ----- 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]
- !
Item was removed:
- ----- Method: TraitDescription>>obsolete (in category 'initialize-release') -----
- obsolete
- "Make the receiver obsolete."
- self organization: nil.
- super obsolete!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- 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>'!
Item was removed:
- ----- Method: TFileInOutDescription>>fileOutCategory: (in category 'fileIn/Out') -----
- fileOutCategory: catName
- ^ self fileOutCategory: catName asHtml: false!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: ClassTrait class>>for: (in category 'instance creation') -----
- for: aTrait
- ^self new
- initializeWithBaseTrait: aTrait;
- yourself!
Item was removed:
- ----- Method: RequiredSelectors>>newlyInterestingClasses: (in category 'accessing') -----
- newlyInterestingClasses: anObject
- newlyInterestingClasses := anObject!
Item was removed:
- ----- Method: SendCaches>>selfSendersOf: (in category 'accessing-specific') -----
- selfSendersOf: selector
- ^ selfSenders at: selector ifAbsent: [#()].!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>c2 (in category 'accessing') -----
- c2
- ^c2!
Item was removed:
- ----- Method: SendInfo>>addSuperSentSelector: (in category 'private') -----
- addSuperSentSelector: aSymbol
- superSentSelectors ifNil: [superSentSelectors := IdentitySet new].
- superSentSelectors add: aSymbol.!
Item was removed:
- ----- Method: SendInfo>>classSentSelectors (in category 'accessing') -----
- classSentSelectors
- ^ classSentSelectors ifNil: [#()] ifNotNil: [classSentSelectors].!
Item was removed:
- ----- Method: FixedIdentitySet class>>sizeFor: (in category 'private') -----
- sizeFor: aCollection
- ^ aCollection species == self
- ifTrue: [aCollection capacity]
- ifFalse: [self defaultSize].!
Item was removed:
- ----- Method: TraitsTestCase>>c4 (in category 'accessing') -----
- c4
- ^TraitsResource current c4!
Item was removed:
- ----- Method: LocalSends>>newCacheFor: (in category 'as yet unclassified') -----
- newCacheFor: aClass
- "Creates an instance of SendCaches, assigns it to the instance variable sendCaches and fills it with all the self-sends class-sends and super-sends that occur in methods defined in this class (or by used traits)."
-
- | localSendCache |
- localSendCache := SendCaches new.
- aClass selectorsAndMethodsDo:
- [:sender :m |
- | info |
- info := (SendInfo on: m) collectSends.
- info selfSentSelectors
- do: [:sentSelector | localSendCache addSelfSender: sender of: sentSelector].
- info superSentSelectors
- do: [:sentSelector | localSendCache addSuperSender: sender of: sentSelector].
- info classSentSelectors
- do: [:sentSelector | localSendCache addClassSender: sender of: sentSelector]].
- ^localSendCache!
Item was removed:
- ----- 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."
- !
Item was removed:
- ----- 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."
- RequiredSelectors doWithTemporaryInstance:
- [LocalSends doWithTemporaryInstance:
- [ProvidedSelectors doWithTemporaryInstance:
- [| noLongerInteresting newInteresting |
- self prepareAllCaches.
- noLongerInteresting := self classesInCategories: {'Morphic-Basic'}.
- newInteresting := self classesInCategories: {'Morphic-Kernel'}.
- self measure:
- [self noteInterestInClasses: newInteresting.
- self loseInterestInClasses: noLongerInteresting.
- newInteresting do: [:cl | cl hasRequiredSelectors].
- self loseInterestInClasses: newInteresting.
- self noteInterestInClasses: noLongerInteresting.].
- self assert: realTime < 500]]]!
Item was removed:
- ----- Method: TraitsResource>>t1 (in category 'accessing') -----
- t1
- ^t1!
Item was removed:
- ----- 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)!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>doWork (in category 'calculating') -----
- doWork
- | requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel |
- requiredSelectorsByClass := IdentityDictionary new.
- oldRequiredSelectorsByClass := IdentityDictionary new.
- classWithOldRequirementsRecorded := IdentitySet new.
- rootsHandledBySel := IdentityDictionary new.
- originalSinsPerSelector keysAndValuesDo:
- [:selector :sinners |
- | rootsHandled |
- rootsHandled := rootsHandledBySel at: selector put: IdentitySet new.
- rootClasses do:
- [:rc |
- (self shouldProcess: rc forSinsIn: sinners)
- ifTrue:
- [rootsHandled add: rc.
- self
- storeOldRequirementsUnder: rc
- into: oldRequiredSelectorsByClass
- ignoreSet: classWithOldRequirementsRecorded.
- self
- storeRequirementsUnder: rc
- for: selector
- in: requiredSelectorsByClass]]].
- self
- removeRequirements: oldRequiredSelectorsByClass
- thatAreNotIn: requiredSelectorsByClass
- ifIn: rootsHandledBySel.
- self setFoundRequirements: requiredSelectorsByClass!
Item was removed:
- ----- Method: RequiredSelectors>>classesOfInterest (in category 'as yet unclassified') -----
- classesOfInterest
- ^interests asIdentitySet!
Item was removed:
- ----- Method: TraitsTestCase>>t3 (in category 'accessing') -----
- t3
- ^TraitsResource current t3!
Item was removed:
- ----- Method: QuickIntegerDictionary>>includesKey: (in category 'accessing') -----
- includesKey: anIntegerKey
- ^ (self at: anIntegerKey) notNil !
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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:!
Item was removed:
- ----- Method: Trait>>classTrait (in category 'accessing parallel hierarchy') -----
- classTrait
- ^classTrait!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendInfo>>pushNewArrayOfSize: (in category 'instruction decoding') -----
- pushNewArrayOfSize: arraySize
- self push: #stuff!
Item was removed:
- ----- Method: SendsInfoTest>>testBranch (in category 'tests') -----
- testBranch
- self assert: #branch sends: #(clip truncate) supersends: #() classSends: #()!
Item was removed:
- ----- Method: RequirementsCache>>superRequirements (in category 'accessing') -----
- superRequirements
- "Answer the value of superRequirements"
-
- ^ superRequirements isNil
- ifTrue: [IdentitySet new]
- ifFalse: [superRequirements].!
Item was removed:
- ----- 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')!
Item was removed:
- ----- Method: TraitBehavior>>removeSelector: (in category 'accessing method dictionary') -----
- removeSelector: selector
- self pureRemoveSelector: selector.
- self notifyUsersOfChangedSelector: selector.!
Item was removed:
- ----- Method: TraitTest>>testTraitMethodSelector (in category 'testing') -----
- testTraitMethodSelector
- "Tests that the #selector of a trait method isn't screwed up when aliasing traits"
- | baseTrait classA classB |
- [ | methodA traitMethod methodB |baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
- baseTrait compileSilently: 'traitMethod' classified: 'tests'.
- traitMethod := baseTrait compiledMethodAt: #traitMethod.
- self assert: traitMethod selector == #traitMethod.
-
- classA := Object subclass: #TraitTestMethodClassA
- uses: {baseTrait @ {#methodA -> #traitMethod}}
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self class category.
- methodA := classA compiledMethodAt: #methodA.
-
- self assert: traitMethod selector == #traitMethod.
- self assert: methodA selector == #methodA.
-
- classB := Object subclass: #TraitTestMethodClassB
- uses: {baseTrait @ {#methodB -> #traitMethod}}
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self class category.
- methodB := classB compiledMethodAt: #methodB.
-
-
- self assert: traitMethod selector == #traitMethod.
- self assert: methodA selector == #methodA.
- self assert: methodB selector == #methodB.
-
- ] ensure:[
- classA ifNotNil:[classA removeFromSystem: false].
- classB ifNotNil:[classB removeFromSystem: false].
- baseTrait ifNotNil:[baseTrait removeFromSystem: false].
- ].!
Item was removed:
- ----- 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).
- !
Item was removed:
- ----- Method: TraitBehavior>>lookupSelector: (in category 'accessing method dictionary') -----
- lookupSelector: selector
- ^(self includesSelector: selector)
- ifTrue: [self compiledMethodAt: selector]
- ifFalse: [nil]!
Item was removed:
- ----- Method: FixedIdentitySet class>>withAll:notIn: (in category 'instance creation') -----
- withAll: aCollection notIn: notCollection
- ^ (self new: (self sizeFor: aCollection)) addAll: aCollection notIn: notCollection; yourself!
Item was removed:
- ----- Method: SendInfo>>collectSends (in category 'initialization') -----
- collectSends
- | end |
- end := self method endPC.
- [pc <= end]
- whileTrue: [self interpretNextInstructionFor: self]!
Item was removed:
- ----- 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"!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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.!
Item was removed:
- 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.!
Item was removed:
- ----- Method: TraitsResource>>c6 (in category 'accessing') -----
- c6
- ^c6!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TPureBehavior>>environment (in category 'naming') -----
- environment
- "Return the environment in which the receiver is visible"
- ^Smalltalk!
Item was removed:
- ----- Method: TraitsTestCase>>c8 (in category 'accessing') -----
- c8
- ^TraitsResource current c8!
Item was removed:
- ----- Method: TraitsTestCase>>tearDown (in category 'running') -----
- tearDown
-
- TraitsResource resetIfDirty.
- self createdClassesAndTraits do:
- [:aClassOrTrait | | behaviorName |
- behaviorName := aClassOrTrait name.
- Smalltalk at: behaviorName
- ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
- ChangeSet current removeClassChanges: behaviorName].
- createdClassesAndTraits := nil!
Item was removed:
- ----- 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].!
Item was removed:
- ----- Method: SendInfo>>selfSentSelectors (in category 'accessing') -----
- selfSentSelectors
- ^ selfSentSelectors ifNil: [#()] ifNotNil: [selfSentSelectors].!
Item was removed:
- ----- Method: TraitsResource>>t5 (in category 'accessing') -----
- t5
- ^t5!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: TraitDescription>>theNonMetaClass (in category 'class compatibility') -----
- theNonMetaClass
- ^ self baseTrait!
Item was removed:
- ----- Method: TCompilingBehavior>>decompilerClass (in category 'compiling') -----
- decompilerClass
- "Answer a decompiler class appropriate for compiled methods of this class."
-
- ^ self compilerClass decompilerClass!
Item was removed:
- ----- 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 )!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Trait>>name (in category 'accessing') -----
- name
- ^name!
Item was removed:
- ----- 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).
-
- !
Item was removed:
- TimeMeasuringTest subclass: #SendCachePerformanceTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-LocalSends'!
Item was removed:
- ----- Method: Trait>>basicCategory (in category 'accessing') -----
- basicCategory
- ^category!
Item was removed:
- ----- Method: SendCaches>>allSentSelectorsAndSendersDo: (in category 'accessing-specific') -----
- allSentSelectorsAndSendersDo: aBlock
- self selfSentSelectorsAndSendersDo: aBlock.
- self superSentSelectorsAndSendersDo: aBlock.
- self classSentSelectorsAndSendersDo: aBlock.!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]
- !
Item was removed:
- ----- Method: TCompilingBehavior>>defaultMethodTrailer (in category 'compiling') -----
- defaultMethodTrailer
- ^ CompiledMethodTrailer empty!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TPureBehavior>>name (in category 'naming') -----
- name
- ^ self explicitRequirement!
Item was removed:
- ----- Method: TPureBehavior>>includesLocalSelector: (in category 'testing method dictionary') -----
- includesLocalSelector: aSymbol
- ^self basicLocalSelectors isNil
- ifTrue: [self includesSelector: aSymbol]
- ifFalse: [self localSelectors includes: aSymbol]!
Item was removed:
- ----- Method: TTraitsCategorisingDescription>>updateOrganizationSelector:oldCategory:newCategory: (in category 'organization updating') -----
- updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil
- | changedCategories composition |
- changedCategories := IdentitySet new.
- composition := self hasTraitComposition
- ifTrue: [self traitComposition]
- ifFalse: [TraitComposition new].
- (composition methodDescriptionsForSelector: aSymbol) do: [:each | | effectiveCategory currentCategory sel |
- sel := each selector.
- (self includesLocalSelector: sel) ifFalse: [
- currentCategory := self organization categoryOfElement: sel.
- effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil.
- effectiveCategory isNil ifTrue: [
- currentCategory ifNotNil: [changedCategories add: currentCategory].
- self organization removeElement: sel.
- ] ifFalse: [
- ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [
- currentCategory ifNotNil: [changedCategories add: currentCategory].
- self organization
- classify: sel
- under: effectiveCategory
- suppressIfDefault: false]]]].
- ^ changedCategories!
Item was removed:
- ----- Method: TUpdateTraitsBehavior>>removeTraitSelector: (in category 'traits') -----
- removeTraitSelector: aSymbol
- self assert: [(self includesLocalSelector: aSymbol) not].
- self basicRemoveSelector: aSymbol!
Item was removed:
- ----- Method: FixedIdentitySet class>>defaultSize (in category 'constants') -----
- defaultSize
- ^ 4!
Item was removed:
- ----- Method: SendInfo>>pop: (in category 'stack manipulation') -----
- pop: n
- stack removeLast: n!
Item was removed:
- ----- 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!
Item was removed:
- TraitsTestCase subclass: #TraitFileOutTest
- instanceVariableNames: 'ca cb ta tb tc td'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: Trait>>binding (in category 'compiling') -----
- binding
-
- ^ Smalltalk associationAt: name ifAbsent: [nil -> self]
- !
Item was removed:
- ----- 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!
Item was removed:
- Object 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.!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitBehavior>>updateRequires (in category 'send caches') -----
- updateRequires
- | sss aTrait |
- sss := self selfSentSelectorsInTrait: aTrait.
- ^sss copyWithoutAll: aTrait allSelectors.!
Item was removed:
- ----- Method: ClassTrait>>hasClassTrait (in category 'accessing parallel hierarchy') -----
- hasClassTrait
- ^false!
Item was removed:
- ----- Method: RequiresTestCase>>selfSentSelectorsInTrait: (in category 'as yet unclassified') -----
- selfSentSelectorsInTrait: aTrait
- ^self selfSentSelectorsInTrait: aTrait fromSelectors: aTrait allSelectors
- !
Item was removed:
- ----- Method: LocatedMethod>>method (in category 'convenience') -----
- method
- ^self location >> self selector!
Item was removed:
- ----- Method: TCompilingDescription>>noteCompilationOf:meta: (in category 'compiling') -----
- noteCompilationOf: aSelector meta: isMeta
- "A hook allowing some classes to react to recompilation of certain selectors"!
Item was removed:
- ----- Method: TTransformationCompatibility>>subject (in category 'enquiries') -----
- subject
- "for compatibility with TraitTransformations"
- ^ self
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TPureBehavior>>prettyPrinterClass (in category 'printing') -----
- prettyPrinterClass
- ^self compilerClass!
Item was removed:
- ----- Method: FixedIdentitySet>>grow (in category 'private') -----
- grow
- | newSelf |
- newSelf := self species new: capacity * 2. "This will double the capacity"
- self do: [ :anObject | newSelf add: anObject ].
- self become: newSelf!
Item was removed:
- ----- Method: TPureBehavior>>hasRequiredSelectors (in category 'send caches') -----
- hasRequiredSelectors
- ^ self requiredSelectors notEmpty!
Item was removed:
- ----- 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!
Item was removed:
- TraitsTestCase subclass: #ClassTraitTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: RequirementsCache>>requirements (in category 'accessing') -----
- requirements
- ^ requirements isNil
- ifTrue: [self newRequirementsObject]
- ifFalse: [requirements].!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.)']!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>touchMorphStep (in category 'as yet unclassified') -----
- touchMorphStep
- Morph compile: (Morph sourceCodeAt: #step ifAbsent: []) asString!
Item was removed:
- ----- 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:"!
Item was removed:
- ----- Method: TraitsResource>>t3: (in category 'accessing') -----
- t3: anObject
- ^t3 := anObject!
Item was removed:
- ----- Method: Trait>>removeFromSystem (in category 'initialize-release') -----
- removeFromSystem
- self removeFromSystem: true!
Item was removed:
- ----- Method: TAccessingTraitCompositionBehavior>>addExclusionOf:to: (in category 'traits') -----
- addExclusionOf: aSymbol to: aTrait
- self setTraitComposition: (
- self traitComposition copyWithExclusionOf: aSymbol to: aTrait)!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>classesToUpdate (in category 'accessing') -----
- classesToUpdate
- ^classesToUpdate!
Item was removed:
- TraitsTestCase subclass: #LocatedMethodTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- CodeModelExtension subclass: #RequiredSelectors
- instanceVariableNames: 'dirty dirtyClasses newlyInterestingClasses'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Requires'!
Item was removed:
- ----- Method: TraitsResource>>c7: (in category 'accessing') -----
- c7: anObject
- ^c7 := anObject!
Item was removed:
- ----- Method: RequiresTestCase>>loseInterestsInAll (in category 'as yet unclassified') -----
- loseInterestsInAll
- ^self createdClassesAndTraits
- , TraitsResource current createdClassesAndTraits
- do: [:e | self loseInterestsFor: e]!
Item was removed:
- ----- 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]
- !
Item was removed:
- ----- 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].
-
- !
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: FixedIdentitySet>>includes: (in category 'testing') -----
- includes: aSymbol
- "This override assumes that pointsTo is a fast primitive"
-
- aSymbol ifNil: [^ false].
- ^ self pointsTo: aSymbol!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: SendCaches>>addClassSender:of: (in category 'updates') -----
- addClassSender: sendingSelector of: sentSelector
- | senders |
- senders := classSenders at: sentSelector ifAbsent: [#()].
- classSenders at: sentSelector put: (senders copyWith: sendingSelector).!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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:"!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TComposingDescription>>- (in category 'composition') -----
- - anArrayOfSelectors
- ^TraitExclusion
- with: self
- exclusions: anArrayOfSelectors!
Item was removed:
- ----- 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).
- !
Item was removed:
- ----- Method: TPureBehavior>>traitCompositionString (in category 'traits') -----
- traitCompositionString
- ^self hasTraitComposition
- ifTrue: [self traitComposition asString]
- ifFalse: ['{}']!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitDescription>>classSide (in category 'accessing parallel hierarchy') -----
- classSide
- ^self classTrait!
Item was removed:
- ----- 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)!
Item was removed:
- ----- Method: TraitDescription>>classTrait (in category 'accessing parallel hierarchy') -----
- classTrait
- self subclassResponsibility!
Item was removed:
- ----- 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]]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: FixedIdentitySet>>at: (in category 'accessing') -----
- at: index
- self shouldNotImplement!
Item was removed:
- ----- Method: SendCaches>>classSendersOf: (in category 'accessing') -----
- classSendersOf: selector
- ^ classSenders at: selector ifAbsent: [#()].!
Item was removed:
- ----- 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]).!
Item was removed:
- ----- Method: TPureBehavior>>allSelectors (in category 'accessing method dictionary') -----
- allSelectors
- self explicitRequirement!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SendsInfoTest>>testClipRect (in category 'tests') -----
- testClipRect
- self assert: #clipRect: sends: #(bitBlt) supersends: #(clipRect:) classSends: #()
- !
Item was removed:
- ----- Method: TCompilingBehavior>>compilerClass (in category 'compiling') -----
- compilerClass
- "Answer a compiler class appropriate for source methods of this class."
-
- ^Compiler!
Item was removed:
- ----- Method: Behavior>>computeTranslationsAndUpdateUnreachableSet: (in category '*Traits-requires') -----
- computeTranslationsAndUpdateUnreachableSet: unreachableCollection
- "This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors."
-
- | translations oldUnreachable |
- oldUnreachable := unreachableCollection copy.
- translations := IdentityDictionary new.
- "Add selectors implemented in this class to unreachable set."
- self methodDict keysDo: [:s | unreachableCollection add: s].
-
- "Fill translation dictionary and remove super-reachable selectors from unreachable."
- self sendCaches superSentSelectorsAndSendersDo: [:sent :senders |
- | reachableSenders |
- reachableSenders := FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable.
- reachableSenders isEmpty ifFalse: [
- translations at: sent put: reachableSenders.
- unreachableCollection remove: sent ifAbsent: [].
- ].
- ].
- ^ translations!
Item was removed:
- ----- Method: TraitDescription>>instanceSide (in category 'accessing parallel hierarchy') -----
- instanceSide
- ^self baseTrait!
Item was removed:
- ----- Method: RequiresOriginalTestCase class>>updateRequiredStatusFor:in: (in category 'as yet unclassified') -----
- updateRequiredStatusFor: selector in: aClass
- aClass updateRequiredStatusFor: selector inSubclasses: self systemNavigation allClassesAndTraits !
Item was removed:
- ----- Method: TTestingDescription>>isMeta (in category 'accessing parallel hierarchy') -----
- isMeta
- ^self isClassSide!
Item was removed:
- ----- Method: TraitsResource>>setUpTwoLevelRequiresFixture (in category 'as yet unclassified') -----
- setUpTwoLevelRequiresFixture
- self c4: (self
- createClassNamed: #C4
- superclass: ProtoObject
- uses: { }).
- ProtoObject removeSubclass: self c4.
- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitBehavior>>traitComposition: (in category 'traits') -----
- traitComposition: aTraitComposition
- traitComposition := aTraitComposition!
Item was removed:
- ----- Method: TUpdateTraitsBehavior>>updateMethodDictionarySelector: (in category 'traits') -----
- updateMethodDictionarySelector: aSymbol
- "A method with selector aSymbol in myself or my traitComposition has been changed.
- Do the appropriate update to my methodDict (remove or update method) and
- return all affected selectors of me so that my useres get notified."
-
- | modifiedSelectors descriptions |
- modifiedSelectors := IdentitySet new.
- descriptions := self hasTraitComposition
- ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ]
- ifFalse: [ #() ].
- descriptions do: [:methodDescription | | effectiveMethod selector |
- selector := methodDescription selector.
- (self includesLocalSelector: selector) ifFalse: [
- methodDescription isEmpty
- ifTrue: [
- self removeTraitSelector: selector.
- modifiedSelectors add: selector]
- ifFalse: [
- effectiveMethod := methodDescription effectiveMethod.
- (self compiledMethodAt: selector ifAbsent: [nil]) ~~ effectiveMethod ifTrue: [
- self addTraitSelector: selector withMethod: effectiveMethod.
- modifiedSelectors add: selector]]]].
- ^modifiedSelectors!
Item was removed:
- Object 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.
- !
Item was removed:
- ----- 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 ))!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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 removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendInfo>>pushConsArrayWithElements: (in category 'instruction decoding') -----
- pushConsArrayWithElements: arraySize
- self pop: arraySize.
- self push: #stuff!
Item was removed:
- ----- 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!
Item was removed:
- Object subclass: #ModelExtension
- instanceVariableNames: 'interests lock'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-LocalSends'!
- ModelExtension class
- instanceVariableNames: 'current'!
Item was removed:
- ----- Method: TBasicCategorisingDescription>>errorCategoryName (in category 'private') -----
- errorCategoryName
- self error: 'Category name must be a String'!
Item was removed:
- ----- Method: TraitTest>>testTraitMethodClass (in category 'testing') -----
- testTraitMethodClass
- "Tests that the #methodClass of a trait method isn't screwed up"
- | baseTrait classA classB |
- [ | methodB traitMethod methodA |baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
- baseTrait compileSilently: 'traitMethod' classified: 'tests'.
- traitMethod := baseTrait compiledMethodAt: #traitMethod.
- self assert: traitMethod methodClass == baseTrait.
-
- classA := Object subclass: #TraitTestMethodClassA
- uses: baseTrait
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self class category.
- methodA := classA compiledMethodAt: #traitMethod.
-
- self assert: traitMethod methodClass == baseTrait.
- self assert: methodA methodClass == classA.
-
- classB := Object subclass: #TraitTestMethodClassB
- uses: baseTrait
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: self class category.
- methodB := classB compiledMethodAt: #traitMethod.
-
-
- self assert: traitMethod methodClass == baseTrait.
- self assert: methodA methodClass == classA.
- self assert: methodB methodClass == classB.
-
- ] ensure:[
- classA ifNotNil:[classA removeFromSystem: false].
- classB ifNotNil:[classB removeFromSystem: false].
- baseTrait ifNotNil:[baseTrait removeFromSystem: false].
- ].!
Item was removed:
- ----- Method: TPureBehavior>>isDisabledSelector: (in category 'testing method dictionary') -----
- isDisabledSelector: selector
- ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TimeMeasuringTest>>workingCopyPredicate (in category 'as yet unclassified') -----
- workingCopyPredicate
- ^[:e | '*Traits*' match: e package name]!
Item was removed:
- ----- Method: RequiresTestCase>>testSins (in category 'as yet unclassified') -----
- testSins
- | caa cab cac cad |
- caa := self
- createClassNamed: #CAA
- superclass: ProtoObject
- uses: { }.
- ProtoObject removeSubclass: caa.
- 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.!
Item was removed:
- ----- Method: SendInfo>>blockReturn (in category 'stack manipulation') -----
- blockReturn
- "we could empty the stack, but what's the point?"!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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 ifNotNil: [ :symbol |
- ((SystemOrganization listAtCategoryNamed: symbol) includes: self name)
- ifTrue: [ ^symbol ] ].
- self basicCategory: (result := SystemOrganization categoryOfElement: self name).
- ^result!
Item was removed:
- ----- Method: TCompilingBehavior>>parseScope (in category 'newcompiler') -----
- parseScope
-
- ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]!
Item was removed:
- ----- Method: TraitBehavior>>subclassDefinerClass (in category 'class compatibility') -----
- subclassDefinerClass
- ^nil subclassDefinerClass !
Item was removed:
- ----- Method: ClassTrait>>initializeWithBaseTrait: (in category 'initialize') -----
- initializeWithBaseTrait: aTrait
- self baseTrait: aTrait.
- self noteNewBaseTraitCompositionApplied: aTrait traitComposition.
- aTrait users do: [:each | self addUser: each classSide].
- !
Item was removed:
- ----- Method: TraitBehavior>>methodDict (in category 'accessing method dictionary') -----
- methodDict
- ^ methodDict!
Item was removed:
- ----- 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].!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitDescription>>addExclusionOf: (in category 'composition') -----
- addExclusionOf: aSymbol
- ^self - {aSymbol}!
Item was removed:
- ----- Method: TraitBehavior>>hasTraitComposition (in category 'traits') -----
- hasTraitComposition
- ^traitComposition notNil and:[traitComposition isEmpty not]!
Item was removed:
- ----- Method: TTransformationCompatibility>>collectMethodsFor:into: (in category 'enquiries') -----
- collectMethodsFor: aSelector into: methodDescription
- (self includesSelector: aSelector) ifTrue: [
- methodDescription addLocatedMethod: (
- LocatedMethod
- location: self
- selector: aSelector)]
- !
Item was removed:
- ----- 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).!
Item was removed:
- ----- Method: SendsInfoTest>>testSuperBranch (in category 'tests') -----
- testSuperBranch
- self assert: #superBranch sends: #(tell should:raise:) supersends: #(tell) classSends: #().
- self superBranch.!
Item was removed:
- ----- Method: QuickStack>>removeAll (in category 'accessing') -----
- removeAll
- top := 0!
Item was removed:
- ----- Method: Trait>>basicCategory: (in category 'accessing') -----
- basicCategory: aSymbol
- category := aSymbol!
Item was removed:
- ----- Method: TraitsResource>>c1 (in category 'accessing') -----
- c1
- ^c1!
Item was removed:
- ----- Method: TCompilingBehavior>>binding (in category 'compiling') -----
- binding
- ^ nil -> self!
Item was removed:
- TestCase subclass: #ATestCase
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: TraitsTestCase>>c3 (in category 'accessing') -----
- c3
- ^TraitsResource current c3!
Item was removed:
- ----- Method: TPureBehavior>>emptyMethodDictionary (in category 'initialization') -----
- emptyMethodDictionary
-
- ^ MethodDictionary new!
Item was removed:
- ----- Method: RequirementsCache>>newRequirementsObject (in category 'accessing') -----
- newRequirementsObject
- ^ IdentitySet new.!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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 !
Item was removed:
- ----- 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 asArray sort)].
- (organization isMemberOf: Array) ifTrue:
- [self recoverFromMDFaultWithTrace].
-
- "Making sure that subject is set correctly. It should not be necessary."
- organization ifNotNil: [organization setSubject: self].
- ^ organization!
Item was removed:
- ----- Method: TraitsResource>>c8 (in category 'accessing') -----
- c8
- ^c8!
Item was removed:
- ----- Method: FixedIdentitySet>>fixCollisionsFrom: (in category 'private') -----
- fixCollisionsFrom: start
- "The element at start has been removed and replaced by nil.
- This method moves forward from there, relocating any entries
- that had been placed below due to collisions with this one."
-
- | key index mask |
- index := start.
- mask := self basicSize - 1.
- [ (key := self basicAt: (index := (index bitAnd: mask) + 1)) == nil ] whileFalse: [
- | newIndex |
- (newIndex := self scanFor: key) = index ifFalse: [
- | element |
- element := self basicAt: index.
- self basicAt: index put: (self basicAt: newIndex).
- self basicAt: newIndex put: element.] ]!
Item was removed:
- ----- Method: TraitsTestCase>>t2 (in category 'accessing') -----
- t2
- ^TraitsResource current t2!
Item was removed:
- ----- Method: QuickStack>>addLast: (in category 'accessing') -----
- addLast: aValue
- top = self basicSize ifTrue: [self grow].
- top := top + 1.
- ^ self at: top put: aValue!
Item was removed:
- ----- 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].!
Item was removed:
- ----- Method: FixedIdentitySet>>at:put: (in category 'accessing') -----
- at: index put: anObject
- self shouldNotImplement!
Item was removed:
- ----- Method: TPureBehavior>>registerLocalSelector: (in category 'accessing method dictionary') -----
- registerLocalSelector: aSymbol
- self basicLocalSelectors notNil ifTrue: [
- self basicLocalSelectors add: aSymbol]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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'.!
Item was removed:
- ----- Method: RequiredSelectors>>newlyInteresting: (in category 'as yet unclassified') -----
- newlyInteresting: aClass
- dirty := true.
- self dirtyClasses add: aClass!
Item was removed:
- ----- Method: SendsInfoTest>>testPseudoCopy (in category 'tests') -----
- testPseudoCopy
- self assert: #pseudoCopy sends: #(instVarsWithIndexDo: basicSize) supersends: #() classSends: #(#new:)!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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 !
Item was removed:
- ----- Method: TraitsResource>>setUpTranslatingRequiresFixture (in category 'as yet unclassified') -----
- setUpTranslatingRequiresFixture
- self c6: (self
- createClassNamed: #C6
- superclass: ProtoObject
- uses: { }).
- ProtoObject removeSubclass: self c6.
- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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: $' ]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Trait class>>newTraitNamed:uses:category: (in category 'instance creation') -----
- newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString
- "Creates a new trait."
- | env |
- env := self environment.
- ^self
- named: aSymbol
- uses: aTraitCompositionOrCollection
- category: aString
- env: env!
Item was removed:
- ----- Method: TraitsResource>>t1: (in category 'accessing') -----
- t1: anObject
- ^t1 := anObject!
Item was removed:
- ----- Method: RequiresTestCase>>testExclusionWithAliasing (in category 'as yet unclassified') -----
- testExclusionWithAliasing
- self assert: ((self requiredMethodsForTrait: t11) = (Set with: #m12)).
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitDescription>>isUniClass (in category 'testing') -----
- isUniClass
- ^false!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: QuickStack>>removeLast: (in category 'accessing') -----
- removeLast: n
-
- top := top - n!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: QuickIntegerDictionary>>removeKey: (in category 'accessing') -----
- removeKey: anIntegerKey
- ^ self at: anIntegerKey put: nil.!
Item was removed:
- ----- Method: TUpdateTraitsBehavior>>notifyUsersOfChangedSelectors: (in category 'traits') -----
- notifyUsersOfChangedSelectors: aCollection!
Item was removed:
- ----- Method: TCompilingBehavior>>compress (in category 'accessing method dictionary') -----
- compress
- "Compact the method dictionary of the receiver."
-
- self methodDict rehash!
Item was removed:
- ----- 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:' '.
- ].
- ].
- !
Item was removed:
- ----- Method: TPureBehavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') -----
- addSelectorSilently: selector withMethod: compiledMethod
- self methodDictAddSelectorSilently: selector withMethod: compiledMethod.
- self registerLocalSelector: selector!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitTest>>testAllClassVarNames (in category 'testing') -----
- testAllClassVarNames
-
-
- self assert: self t1 allClassVarNames isEmpty!
Item was removed:
- ----- Method: TraitsResource>>c5: (in category 'accessing') -----
- c5: anObject
- ^c5 := anObject!
Item was removed:
- ----- Method: TraitsResource>>c5 (in category 'accessing') -----
- c5
- ^c5!
Item was removed:
- ----- Method: TUpdateTraitsBehavior>>notifyUsersOfChangedSelector: (in category 'traits') -----
- notifyUsersOfChangedSelector: aSelector
- self notifyUsersOfChangedSelectors: (Array with: aSelector)!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: FixedIdentitySet class>>new: (in category 'instance creation') -----
- new: anInteger
- ^ (self basicNew: (self arraySizeForCapacity: anInteger)) initializeCapacity: anInteger!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn: (in category 'calculating') -----
- removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass
- oldRequiredSelectorsByClass keysAndValuesDo:
- [:class :requirements |
- | cache newRequirements |
- newRequirements := requiredSelectorsByClass at: class
- ifAbsent:
- [#()].
- cache := class requiredSelectorsCache.
- requirements
- do: [:sel | (newRequirements includes: sel) ifFalse: [cache removeRequirement: sel]]]!
Item was removed:
- ----- Method: TraitsTestCase>>c7 (in category 'accessing') -----
- c7
- ^TraitsResource current c7!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: ClassTrait>>isClassTrait (in category 'accessing parallel hierarchy') -----
- isClassTrait
- ^true!
Item was removed:
- ----- Method: TCompilingBehavior>>parserClass (in category 'compiling') -----
- parserClass
- "Answer a parser class to use for parsing method headers."
-
- ^self compilerClass parserClass!
Item was removed:
- ----- Method: TraitsResource>>t4 (in category 'accessing') -----
- t4
- ^t4!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: TraitsTestCase>>t6 (in category 'accessing') -----
- t6
- ^TraitsResource current t6!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>traitsToUpdate: (in category 'accessing') -----
- traitsToUpdate: anObject
- traitsToUpdate := anObject!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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.
-
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: QuickStack>>replaceFrom:to:with:startingAt: (in category 'private') -----
- replaceFrom: start to: stop with: replacement startingAt: repStart
- "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
- <primitive: 105>
- | index repOff |
- repOff := repStart - start.
- index := start - 1.
- [(index := index + 1) <= stop]
- whileTrue: [self at: index put: (replacement at: repOff + index)]!
Item was removed:
- ----- 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])!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>workingCopyPredicate (in category 'as yet unclassified') -----
- workingCopyPredicate
- ^[:e | {'TraitsOmniBrowser'. 'Traits'} includes: e package name]!
Item was removed:
- ----- Method: ClassTrait>>definitionST80 (in category 'fileIn/Out') -----
- definitionST80
- ^String streamContents: [:stream |
- stream
- nextPutAll: self name;
- crtab;
- nextPutAll: 'uses: ';
- nextPutAll: self traitCompositionString]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Trait>>initialize (in category 'initialize-release') -----
- initialize
- super initialize.
- classTrait := ClassTrait for: self!
Item was removed:
- ----- Method: TPrintingDescription>>printOn: (in category 'printing') -----
- printOn: aStream
- aStream nextPutAll: self name!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- 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].!
Item was removed:
- ----- Method: TPureBehavior>>formalParametersAt: (in category 'accessing method dictionary') -----
- formalParametersAt: aSelector
- "Return the names of the arguments used in this method."
-
- | source |
- source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now"
- ^(self parserClass new) parseParameterNames: source!
Item was removed:
- ----- 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."!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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:
- "
-
-
- !
Item was removed:
- ----- 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 ]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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) ifNotNil: [ :trait |
- self deny: (trait >> selector = (each >> selector)) ] ] ] ] ].!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TFileInOutDescription>>printCategoryChunk:on: (in category 'fileIn/Out') -----
- printCategoryChunk: categoryName on: aFileStream
- ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream!
Item was removed:
- ----- Method: LocatedMethod>>location:selector: (in category 'accessing') -----
- location: aPureBehavior selector: aSymbol
- location := aPureBehavior.
- selector := aSymbol!
Item was removed:
- ----- Method: LocatedMethod>>isBinarySelector (in category 'testing') -----
- isBinarySelector
- ^self selector
- allSatisfy: [:each | each isSpecial]!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>modifiedBehaviors (in category 'accessing') -----
- modifiedBehaviors
- ^modifiedBehaviors!
Item was removed:
- ----- Method: FixedIdentitySet class>>with: (in category 'instance creation') -----
- with: anObject
- "Answer an instance of me containing anObject."
-
- ^ self new
- add: anObject;
- yourself!
Item was removed:
- ----- Method: ModelExtension>>lostInterest:inAll: (in category 'interests') -----
- lostInterest: client inAll: classes
- lock critical: [interests removeAll: classes]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Trait class>>new (in category 'instance creation') -----
- new
- self shouldNotImplement!
Item was removed:
- ----- Method: Behavior>>allTraits (in category '*Traits') -----
- allTraits
- "Answer all the traits that are used by myself without their transformations"
- ^self traitComposition isEmpty
- ifTrue:[#()]
- ifFalse:[self traitComposition allTraits].!
Item was removed:
- ----- Method: SendsInfoTest>>superBranch (in category 'test subjects') -----
- superBranch
- self
- should: [state isNil
- ifTrue: [super tell]
- ifFalse: [self tell]]
- raise: MessageNotUnderstood!
Item was removed:
- ----- Method: TraitDescription>>category: (in category 'organization') -----
- category: aString
- self subclassResponsibility!
Item was removed:
- ----- Method: TPureBehavior>>clearSendCaches (in category 'send caches') -----
- clearSendCaches
- LocalSends current clearOut: self!
Item was removed:
- ----- 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 removed:
- ----- Method: Trait>>isBaseTrait (in category 'accessing parallel hierarchy') -----
- isBaseTrait
- ^true!
Item was removed:
- ----- 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)!
Item was removed:
- ----- 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 removed:
- ----- Method: SendInfo>>addSelfSentSelector: (in category 'private') -----
- addSelfSentSelector: aSymbol
- selfSentSelectors ifNil: [selfSentSelectors := IdentitySet new].
- selfSentSelectors add: aSymbol.!
Item was removed:
- ----- 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
- !
Item was removed:
- ----- Method: ClassTrait>>baseTrait (in category 'accessing parallel hierarchy') -----
- baseTrait
- ^baseTrait!
Item was removed:
- ----- Method: TComposingDescription>>asTraitComposition (in category 'converting') -----
- asTraitComposition
- ^TraitComposition with: self!
Item was removed:
- ----- Method: TPrintingDescription>>storeOn: (in category 'printing') -----
- storeOn: aStream
- "Classes and Metaclasses have global names."
-
- aStream nextPutAll: self name!
Item was removed:
- ----- Method: Trait class>>newTraitComposition (in category 'accessing') -----
- newTraitComposition
- "Creates a new TraitComposition"
- ^TraitComposition new!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>targetBehaviors: (in category 'accessing') -----
- targetBehaviors: anObject
- targetBehaviors := anObject!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: RequiredSelectors>>classChanged: (in category 'invalidation') -----
- classChanged: modificationEvent
- self dirtyWithChange: modificationEvent!
Item was removed:
- ----- Method: TraitBehavior>>sharedPools (in category 'remove me later') -----
- sharedPools
- ^ Dictionary new!
Item was removed:
- ----- Method: Behavior>>classesComposedWithMe (in category '*Traits-requires') -----
- classesComposedWithMe
- ^{self}!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: TAccessingMethodDictDescription>>addAndClassifySelector:withMethod:inProtocol:notifying: (in category 'accessing method dictionary') -----
- addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor
- | priorMethodOrNil |
- priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil].
- self addSelectorSilently: selector withMethod: compiledMethod.
- SystemChangeNotifier uniqueInstance
- doSilently: [self organization classify: selector under: category].
- 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 requestor: requestor].!
Item was removed:
- ----- Method: TraitsTestCase>>createdClassesAndTraits (in category 'utility') -----
- createdClassesAndTraits
- createdClassesAndTraits ifNil: [
- createdClassesAndTraits := OrderedCollection new].
- ^createdClassesAndTraits!
Item was removed:
- ----- Method: SendsInfoTest>>testClip (in category 'tests') -----
- testClip
- self assert: #clip sends: #(printString) supersends: #() classSends: #()!
Item was removed:
- ----- Method: RequiresTestCase>>testStandAloneTrait (in category 'as yet unclassified') -----
- testStandAloneTrait
- self assert: ((self requiredMethodsForTrait: t7) = (Set with: #m12)).!
Item was removed:
- ----- Method: SendInfo>>pushReceiver (in category 'instruction decoding') -----
- pushReceiver
- self push: #self.!
Item was removed:
- ----- 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 !
Item was removed:
- ----- Method: TCommentDescription>>commentStamp: (in category 'fileIn/Out') -----
- commentStamp: changeStamp
- self organization commentStamp: changeStamp.
- ^ self commentStamp: changeStamp prior: 0!
Item was removed:
- ----- Method: TCompilingBehavior>>sourceCodeAt:ifAbsent: (in category 'accessing method dictionary') -----
- sourceCodeAt: selector ifAbsent: aBlock
-
- ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self!
Item was removed:
- ----- 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"!
Item was removed:
- ----- Method: TTransformationCompatibility>>aliasesForSelector: (in category 'enquiries') -----
- aliasesForSelector: aSelector
- ^ OrderedCollection new
- !
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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].!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: LocatedMethod>>hash (in category 'comparing') -----
- hash
- ^ self method scaledIdentityHash!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: FixedIdentitySet>>remove:ifAbsent: (in category 'removing') -----
- remove: anObject ifAbsent: aBlock
- | index element |
- index := self scanFor: anObject.
- (element := self basicAt: index) ifNil: [ ^aBlock value ].
- self basicAt: index put: nil.
- tally := tally - 1.
- self fixCollisionsFrom: index.
- ^element!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>touchObjectHalt (in category 'as yet unclassified') -----
- touchObjectHalt
- ^Object compile: (Object sourceCodeAt: #halt ifAbsent: []) asString!
Item was removed:
- ----- 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}'!
Item was removed:
- ----- 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'.
- !
Item was removed:
- ----- Method: Trait>>removeFromSystem: (in category 'initialize-release') -----
- removeFromSystem: logged
- self environment forgetClass: self logged: logged.
- self obsolete!
Item was removed:
- ----- Method: Behavior>>providedSelectors (in category '*Traits') -----
- providedSelectors
- ^ProvidedSelectors current for: self!
Item was removed:
- ----- Method: TraitBehavior>>removeFromTraitCompositionOfUsers (in category 'traits') -----
- removeFromTraitCompositionOfUsers
- self users do: [:each |
- each removeFromComposition: self ]!
Item was removed:
- ----- Method: TPureBehavior>>providedSelectors (in category '*Traits') -----
- providedSelectors
- ^ProvidedSelectors current for: self!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- Method: TimeMeasuringTest>>initialize (in category 'as yet unclassified') -----
- initialize
- shouldProfile := false.!
Item was removed:
- ----- Method: Behavior>>requiredSelectors (in category '*Traits-requires') -----
- requiredSelectors
- ^RequiredSelectors current for: self!
Item was removed:
- ----- Method: TCompilingBehavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') -----
- addSelectorSilently: selector withMethod: compiledMethod
- self basicAddSelector: selector withMethod: compiledMethod!
Item was removed:
- ----- Method: TraitsTestCase>>assertPrints:like: (in category 'utility') -----
- assertPrints: aString like: anotherString
- self assert: (aString copyWithout: $ )
- = (anotherString copyWithout: $ )!
Item was removed:
- ----- 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'!
Item was removed:
- ----- Method: SendInfo>>pop (in category 'stack manipulation') -----
- pop
- ^ stack removeLast!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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).
-
-
- !
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>c3: (in category 'accessing') -----
- c3: anObject
- ^c3 := anObject!
Item was removed:
- ----- Method: TimeMeasuringTest>>setToDebug (in category 'as yet unclassified') -----
- setToDebug
- shouldProfile := true
- !
Item was removed:
- ----- Method: TUpdateTraitsBehavior>>setTraitCompositionFrom: (in category 'traits') -----
- setTraitCompositionFrom: aTraitExpression
- ^ self setTraitComposition: aTraitExpression asTraitComposition!
Item was removed:
- ----- Method: TraitDescription>>isTestCase (in category 'testing') -----
- isTestCase
- ^false!
Item was removed:
- ----- Method: Behavior>>translateReachableSelfSenders:translations: (in category '*Traits-requires') -----
- translateReachableSelfSenders: senderCollection translations: translationDictionary
- | result |
- (translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection].
- result := FixedIdentitySet new: senderCollection size * 2.
- senderCollection do: [:s |
- | superSenders |
- superSenders := translationDictionary at: s ifAbsent: [nil].
- superSenders
- ifNil: [result add: s]
- ifNotNil: [result addAll: superSenders].
- ].
- ^ result.!
Item was removed:
- ----- Method: TraitTest>>testPrinting (in category 'testing') -----
- testPrinting
- self assertPrints: self t6 definitionST80
- like: 'Trait named: #T6
- uses: T1 + T2 @ {#m22Alias->#m22}
- category: ''Traits-Tests'''!
Item was removed:
- ----- Method: Trait>>applyChangesOfNewTraitCompositionReplacing: (in category 'private') -----
- applyChangesOfNewTraitCompositionReplacing: oldComposition
- "Duplicated on Class"
-
- | changedSelectors |
- changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition.
- self classSide
- noteNewBaseTraitCompositionApplied: self traitComposition.
- ^ changedSelectors!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>setFoundRequirements: (in category 'calculating') -----
- setFoundRequirements: requiredSelectorsByClass
- | cache |
- requiredSelectorsByClass keysAndValuesDo:
- [:class :requirements |
- cache := class requiredSelectorsCache.
- requirements do: [:sel | cache addRequirement: sel]].
- ^cache!
Item was removed:
- ----- Method: TraitBehavior>>classPool (in category 'remove me later') -----
- classPool
- ^ Dictionary new!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TimeMeasuringTest>>versionInfoForWorkingCopiesThat: (in category 'as yet unclassified') -----
- versionInfoForWorkingCopiesThat: wcPredicate
- ^(MCWorkingCopy allManagers select: wcPredicate) inject: ''
- into: [:s :e | s , e description]!
Item was removed:
- ----- 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 asSet]!
Item was removed:
- ----- Method: TPureBehavior>>superRequirements (in category 'send caches') -----
- superRequirements
- ^ self requiredSelectorsCache superRequirements!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TCompilingBehavior>>methodDictionary: (in category 'accessing method dictionary') -----
- methodDictionary: aDictionary
- self methodDict: aDictionary!
Item was removed:
- ----- Method: TCompilingBehavior>>selectorsWithArgs: (in category 'accessing method dictionary') -----
- selectorsWithArgs: numberOfArgs
- "Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this."
-
- | list |
- list := OrderedCollection new.
- self selectorsDo: [:aSel | | num |
- num := aSel count: [:char | char == $:].
- num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]].
- num = numberOfArgs ifTrue: [list add: aSel]].
- ^ list!
Item was removed:
- ----- Method: RequiresTestCase>>noteInterestsForAll (in category 'as yet unclassified') -----
- noteInterestsForAll
- self createdClassesAndTraits
- , TraitsResource current createdClassesAndTraits
- do: [:e | self noteInterestsFor: e]!
Item was removed:
- ----- Method: Trait class>>defaultEnvironment (in category 'instance creation') -----
- defaultEnvironment
- ^Smalltalk!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: SendInfo>>superSentSelectors (in category 'accessing') -----
- superSentSelectors
- ^ superSentSelectors ifNil: [#()] ifNotNil: [superSentSelectors].!
Item was removed:
- ----- Method: ModelExtension class>>current (in category 'accessing') -----
- current
- ^current!
Item was removed:
- ----- 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].!
Item was removed:
- ----- 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).!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- 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] !
Item was removed:
- ----- Method: FixedIdentitySet>>size (in category 'accessing') -----
- size
- ^ tally!
Item was removed:
- ----- Method: Trait>>isValidTraitName: (in category 'private') -----
- isValidTraitName: aSymbol
- ^(aSymbol isEmptyOrNil
- or: [aSymbol first isLetter not]
- or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not!
Item was removed:
- ----- Method: QuickStack>>initialize (in category 'initialization') -----
- initialize
- top := 0!
Item was removed:
- ----- 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.
- !
Item was removed:
- ----- Method: TAccessingTraitCompositionBehavior>>removeFromComposition: (in category 'traits') -----
- removeFromComposition: aTrait
- self setTraitComposition: (self traitComposition copy
- removeFromComposition: aTrait)!
Item was removed:
- ----- 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))
- !
Item was removed:
- ----- Method: Trait class>>allTraitsDo: (in category 'accessing') -----
- allTraitsDo: aBlock
- "Evaluate aBlock with all the instance and class traits present in the system"
- Trait allInstances , ClassTrait allInstances do: [:trait | aBlock value: trait].!
Item was removed:
- ----- Method: TCompilingDescription>>wantsRecompilationProgressReported (in category 'compiling') -----
- wantsRecompilationProgressReported
- "Answer whether the receiver would like progress of its recompilation reported interactively to the user."
-
- ^ true!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TraitBehavior>>addSelectorSilently:withMethod: (in category 'accessing method dictionary') -----
- addSelectorSilently: selector withMethod: compiledMethod
- self pureAddSelectorSilently: selector withMethod: compiledMethod.
- self notifyUsersOfChangedSelector: selector.!
Item was removed:
- ----- Method: TraitsTestCase>>c2 (in category 'accessing') -----
- c2
- ^TraitsResource current c2!
Item was removed:
- ----- Method: Trait>>hasClassTrait (in category 'accessing parallel hierarchy') -----
- hasClassTrait
- ^classTrait notNil!
Item was removed:
- ----- 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]!
Item was removed:
- ----- 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) ifNotNil:[: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) ifNotNil:[: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 removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsTestCase>>t1 (in category 'accessing') -----
- t1
- ^TraitsResource current t1!
Item was removed:
- ----- Method: QuickStack>>removeLast (in category 'accessing') -----
- removeLast
- | answer |
- answer := self at: top.
- top := top - 1.
- ^ answer!
Item was removed:
- ----- Method: FixedIdentitySet>>rehash (in category 'private') -----
- rehash
- | newSelf |
- newSelf := self species new: self size.
- self do: [ :anObject | newSelf add: anObject ].
- ^newSelf!
Item was removed:
- ----- Method: TPureBehavior>>basicLocalSelectors: (in category 'accessing method dictionary') -----
- basicLocalSelectors: aSetOrNil
- self explicitRequirement!
Item was removed:
- ----- Method: RequiresSpeedTestCase>>touchParseNodeComment (in category 'as yet unclassified') -----
- touchParseNodeComment
- ParseNode compile: (ParseNode sourceCodeAt: #comment ifAbsent: []) asString!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>setUpTrivialRequiresFixture (in category 'as yet unclassified') -----
- setUpTrivialRequiresFixture
- self c3: (self
- createClassNamed: #C3
- superclass: ProtoObject
- uses: { }).
- ProtoObject removeSubclass: self c3.
- self c3 superclass: nil.
- self c3 compile: 'foo ^self bla' classified: #accessing!
Item was removed:
- ----- Method: ModelExtension class>>doWithTemporaryInstance: (in category 'instance creation') -----
- doWithTemporaryInstance: aBlock
- | singleton |
- singleton := self current.
-
- [self current: self new.
- aBlock value] ensure: [self current: singleton]!
Item was removed:
- RequiresSpeedTestCase subclass: #FullMERequiresSpeedTestCase
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Requires'!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: LocatedMethod>>argumentNames (in category 'comparing') -----
- argumentNames
- "Return an array with the argument names of the method's selector"
-
- | keywords stream argumentNames delimiters |
- delimiters := {Character space. Character cr}.
- keywords := self selector keywords.
- stream := self source readStream.
- argumentNames := OrderedCollection new.
- keywords do: [ :each | | argumentName |
- stream match: each.
- [stream peekFor: Character space] whileTrue.
- argumentName := ReadWriteStream on: String new.
- [(delimiters includes: stream peek) or: [stream peek isNil]]
- whileFalse: [argumentName nextPut: stream next].
- argumentName isEmpty ifFalse: [
- argumentNames add: argumentName contents withBlanksTrimmed]].
- ^(argumentNames copyFrom: 1 to: self method numArgs) asArray!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitBehavior>>methodDict: (in category 'accessing method dictionary') -----
- methodDict: aDictionary
- methodDict := aDictionary!
Item was removed:
- ----- Method: TraitBehavior>>inheritsFrom: (in category 'class compatibility') -----
- inheritsFrom: aClass
- "Used by RB"
-
- ^false!
Item was removed:
- ----- Method: TPureBehavior>>lookupSelector: (in category 'accessing method dictionary') -----
- lookupSelector: selector
- ^ self explicitRequirement!
Item was removed:
- ----- Method: TPureBehavior>>setRequiredStatusOf:to: (in category 'send caches') -----
- setRequiredStatusOf: selector to: aBoolean
- aBoolean
- ifTrue: [self requiredSelectorsCache addRequirement: selector]
- ifFalse: [self requiredSelectorsCache removeRequirement: selector].!
Item was removed:
- ----- 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)
-
- !
Item was removed:
- ----- Method: SendsInfoTest>>tell (in category 'test subjects') -----
- tell
- "this method should not be defined in super"!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TPureBehavior>>includesBehavior: (in category 'testing') -----
- includesBehavior: aBehavior
- ^self == aBehavior!
Item was removed:
- ----- Method: TraitBehavior>>classVarNames (in category 'class compatibility') -----
- classVarNames
- ^#()!
Item was removed:
- ----- 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.!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TTransformationCompatibility>>trait (in category 'enquiries') -----
- trait
- "for compatibility with TraitTransformations"
- ^ self
- !
Item was removed:
- ----- Method: TraitDescription>>isBaseTrait (in category 'accessing parallel hierarchy') -----
- isBaseTrait
- self subclassResponsibility!
Item was removed:
- ----- Method: TraitBehavior>>instVarNames (in category 'class compatibility') -----
- instVarNames
- ^#()!
Item was removed:
- ----- 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."
-
- self withAllSuperclassesDo: [:class |
- | method |
- method := class compiledMethodAt: aSymbol ifAbsent: [nil].
- method ifNotNil: [^ binaryBlock value: class value: method].
- ].
- ^ absentBlock value.!
Item was removed:
- ----- Method: CodeModelExtension class>>isAbstract (in category 'initialize-release') -----
- isAbstract
- ^self == CodeModelExtension!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: FixedIdentitySet>>initializeCapacity: (in category 'initialize-release') -----
- initializeCapacity: anInteger
- tally := 0.
- capacity := anInteger.
- hashShift := self basicSize highBit - 4096 highBit max: 0!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TraitsResource>>c4 (in category 'accessing') -----
- c4
- ^c4!
Item was removed:
- ----- Method: Trait>>requirements (in category 'accessing') -----
- requirements
- ^self requiredSelectors!
Item was removed:
- ----- 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: $]!
Item was removed:
- ----- Method: SendCaches>>superSenders (in category 'accessing') -----
- superSenders
- ^superSenders!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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].!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>t3 (in category 'accessing') -----
- t3
- ^t3!
Item was removed:
- ----- Method: TraitBehavior>>addUser: (in category 'traits') -----
- addUser: aClassOrTrait
- users add: aClassOrTrait!
Item was removed:
- ----- Method: TimeMeasuringTest>>openDebuggerOnFailingTestMethod (in category 'as yet unclassified') -----
- openDebuggerOnFailingTestMethod
- shouldProfile := true!
Item was removed:
- ----- Method: TraitDescription>>linesOfCode (in category 'private') -----
- linesOfCode
- "An approximate measure of lines of code.
- Includes comments, but excludes blank lines."
- | lines |
- lines := self methodDict inject: 0 into: [:sum :each | sum + each linesOfCode].
- self isMeta
- ifTrue: [^ lines]
- ifFalse: [^ lines + self class linesOfCode]!
Item was removed:
- ----- Method: TraitBehavior>>forgetDoIts (in category 'initialize-release') -----
- forgetDoIts
- "get rid of old DoIt methods"
- self
- basicRemoveSelector: #DoIt;
- basicRemoveSelector: #DoItIn:!
Item was removed:
- ----- Method: TraitsTestCase>>t5 (in category 'accessing') -----
- t5
- ^TraitsResource current t5!
Item was removed:
- ----- Method: TraitsTestCase>>c6 (in category 'accessing') -----
- c6
- ^TraitsResource current c6!
Item was removed:
- ----- 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)!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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]]!
Item was removed:
- ----- Method: Trait>>name: (in category 'accessing') -----
- name: aSymbol
- name := aSymbol!
Item was removed:
- ----- Method: SendInfo>>addClassSentSelector: (in category 'private') -----
- addClassSentSelector: aSymbol
- classSentSelectors ifNil: [classSentSelectors := IdentitySet new].
- classSentSelectors add: aSymbol.!
Item was removed:
- ----- Method: TraitDescription>>printUsersOf:on:level: (in category 'printing') -----
- printUsersOf: aClass on: aStream level: indent
- aStream crtab: indent.
- aStream nextPutAll: aClass name.
- aClass isTrait ifTrue:[
- aClass users do:[:each| self printUsersOf: each on: aStream level: indent+1].
- ].
- !
Item was removed:
- ----- Method: SendInfo>>interpretNextInstructionFor: (in category 'instruction decoding') -----
- interpretNextInstructionFor: client
- self atMergePoint
- ifTrue: [self mergeStacks].
- super interpretNextInstructionFor: client!
Item was removed:
- ----- Method: TraitFileOutTest>>categoryName (in category 'running') -----
- categoryName
- ^'Traits-Tests-FileOut'!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: TraitBehavior>>instSize (in category 'class compatibility') -----
- instSize
- ^0!
Item was removed:
- ----- 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])!
Item was removed:
- ----- Method: TCompilingBehavior>>copyOfMethodDictionary (in category 'copying') -----
- copyOfMethodDictionary
- "Return a copy of the receiver's method dictionary"
-
- ^ self methodDict copy!
Item was removed:
- ----- 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]!
Item was removed:
- ----- Method: TPureBehavior>>traitCompositionIncludes: (in category 'traits') -----
- traitCompositionIncludes: aTrait
- ^self == aTrait or:
- [self hasTraitComposition and:
- [self traitComposition allTraits includes: aTrait]]!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TPureBehavior>>requirements (in category 'send caches') -----
- requirements
- ^ self requiredSelectorsCache
- ifNil: [#()]
- ifNotNil: [:rsc | rsc requirements]!
Item was removed:
- ----- Method: RequiredSelectors>>newlyInterestingClasses (in category 'accessing') -----
- newlyInterestingClasses
- newlyInterestingClasses ifNil: [newlyInterestingClasses := IdentitySet new].
- ^newlyInterestingClasses!
Item was removed:
- ----- Method: TraitsTestCase>>resourceClassesAndTraits (in category 'utility') -----
- resourceClassesAndTraits
- ^TraitsResource current createdClassesAndTraits!
Item was removed:
- ----- 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:.
- !
Item was removed:
- ----- 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}.
- !
Item was removed:
- ----- Method: TraitTest>>testPrintingClassSide (in category 'testing') -----
- testPrintingClassSide
- "self run: #testPrintingClassSide"
-
- self assertPrints: self t6 classSide definitionST80
- like: 'T6 classTrait
- uses: T1 classTrait + T2 classTrait'!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: ClassTrait>>classTrait: (in category 'accessing parallel hierarchy') -----
- classTrait: aClassTrait
- self error: 'Trait is already a class trait!!'
-
- !
Item was removed:
- ----- 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 removed:
- ----- Method: FixedIdentitySet class>>arraySizeForCapacity: (in category 'private') -----
- 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].!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: RequiresTestCase class>>isAbstract (in category 'as yet unclassified') -----
- isAbstract
- ^self == RequiresTestCase!
Item was removed:
- ----- 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 removed:
- ----- Method: TraitBehavior>>removeUser: (in category 'traits') -----
- removeUser: aClassOrTrait
- users remove: aClassOrTrait ifAbsent: []!
Item was removed:
- ----- Method: TraitDescription>>baseTrait (in category 'accessing parallel hierarchy') -----
- baseTrait
- self subclassResponsibility!
Item was removed:
- RequiresTestCase subclass: #RequiresOriginalTestCase
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- 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 removed:
- ----- Method: TraitBehavior>>classesComposedWithMe (in category 'traits') -----
- classesComposedWithMe
- ^users gather: [:u | u classesComposedWithMe]
- !
Item was removed:
- ----- 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 asArray sort collect: [:x | Array
- with: (String with: Character cr), x
- with: (self whichSelectorsReferTo: x)]
-
- "Point crossReference."!
Item was removed:
- ----- Method: SendInfo>>newEmptyStack (in category 'stack manipulation') -----
- newEmptyStack
- stack := QuickStack new!
Item was removed:
- ----- Method: LocatedMethod>>source (in category 'convenience') -----
- source
- ^(self method
- getSourceFor: self selector
- in: self location) asString!
Item was removed:
- ----- 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'!
Item was removed:
- ----- 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.!
Item was removed:
- ----- Method: TraitBehavior>>isTrait (in category 'testing') -----
- isTrait
- ^true!
Item was removed:
- ----- Method: TraitsResource>>c1: (in category 'accessing') -----
- c1: anObject
- ^c1 := anObject!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitsResource>>t6: (in category 'accessing') -----
- t6: anObject
- ^t6 := anObject!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendCaches class>>initializeAllInstances (in category 'fixup') -----
- initializeAllInstances
- self allSubInstancesDo: [ : each | each properlyInitialize ]!
Item was removed:
- ----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') -----
- tearDown
-
- SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
- self createdClassesAndTraits do:
- [:aClassOrTrait | | behaviorName |
- behaviorName := aClassOrTrait name.
- Smalltalk at: behaviorName
- ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
- ChangeSet current removeClassChanges: behaviorName].
- createdClassesAndTraits := self t1: (self
- t2: (self t3: (self
- t4: (self t5: (self
- t6: (self c1: (self
- c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))!
Item was removed:
- ----- Method: TPureBehavior>>purgeLocalSelectors (in category 'traits') -----
- purgeLocalSelectors
- self basicLocalSelectors: nil!
Item was removed:
- TraitsTestCase subclass: #TraitTest
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- TestCase subclass: #SendsInfoTest
- instanceVariableNames: 'state'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Tests'!
Item was removed:
- ----- Method: TraitBehavior>>traitComposition (in category 'traits') -----
- traitComposition
- traitComposition ifNil: [traitComposition := TraitComposition new].
- ^traitComposition!
Item was removed:
- ----- Method: TPureBehavior>>ultimateSourceCodeAt:ifAbsent: (in category 'accessing method dictionary') -----
- ultimateSourceCodeAt: selector ifAbsent: aBlock
- "Return the source code at selector"
-
- ^self
- sourceCodeAt: selector
- ifAbsent: aBlock!
Item was removed:
- ----- Method: TTransformationCompatibility>>allAliasesDict (in category 'enquiries') -----
- allAliasesDict
- ^IdentityDictionary new
- !
Item was removed:
- ----- Method: TPureBehavior>>selfSentSelectorsFromSelectors: (in category 'traits') -----
- selfSentSelectorsFromSelectors: interestingSelectors
- | result |
- result := IdentitySet new.
- interestingSelectors collect:
- [:sel |
- | m info |
- m := self compiledMethodAt: sel ifAbsent: [].
- m ifNotNil:
- [info := (SendInfo on: m) collectSends.
- info selfSentSelectors do: [:sentSelector | result add: sentSelector]]].
- ^result!
Item was removed:
- ----- Method: TComposingDescription>>addCompositionOnLeft: (in category 'private') -----
- addCompositionOnLeft: aTraitComposition
- ^ aTraitComposition add: self!
Item was removed:
- ----- Method: TraitsResource>>setDirty (in category 'accessing') -----
- setDirty
- dirty := true!
Item was removed:
- ----- Method: FixedIdentitySet>>scanFor: (in category 'private') -----
- scanFor: anObject
- "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or raise an error if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
-
- | index start mask |
- anObject ifNil: [self error: 'This class collection cannot handle nil as an element'].
- mask := self basicSize - 1.
- index := start := ((anObject identityHash bitShift: hashShift) bitAnd: mask) + 1.
- [
- | element |
- ((element := self basicAt: index) == nil or: [ element == anObject ])
- ifTrue: [ ^index ].
- (index := (index bitAnd: mask) + 1) = start ] whileFalse.
- self errorNoFreeSpace!
Item was removed:
- ----- Method: CodeModelExtension>>for: (in category 'access to cache') -----
- for: aClass
- ^perClassCache at: aClass
- ifAbsent:
- [| newSendCache |
- newSendCache := self newCacheFor: aClass.
- (self haveInterestsIn: aClass)
- ifTrue: [perClassCache at: aClass put: newSendCache].
- newSendCache]!
Item was removed:
- ----- Method: TraitsTestCase>>categoryName (in category 'running') -----
- categoryName
- ^self class category!
Item was removed:
- ----- Method: TTestingDescription>>isInstanceSide (in category 'accessing parallel hierarchy') -----
- isInstanceSide
- ^self isClassSide not!
Item was removed:
- ----- Method: RequiredSelectorsChangesCalculator>>addUpdatePathTo:from: (in category 'as yet unclassified') -----
- addUpdatePathTo: aClass from: highRoot
- aClass withAllSuperclassesDo: [:sc | classesToUpdate add: sc. highRoot = sc ifTrue: [^self]]!
Item was removed:
- ----- Method: SendsInfoTest>>assert:sendsIn:are: (in category 'test subjects') -----
- assert: levelSymbol sendsIn: aSelector are: anArrayOfSelectors
-
- !
Item was removed:
- ----- Method: LocatedMethod>>= (in category 'comparing') -----
- = aLocatedMethod
- ^ self method == aLocatedMethod method !
Item was removed:
- ----- Method: TraitBehavior>>precodeCommentOrInheritedCommentFor: (in category 'accessing method dictionary') -----
- precodeCommentOrInheritedCommentFor: aSelector
- ^self firstPrecodeCommentFor: aSelector
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendsInfoTest>>classBranch (in category 'test subjects') -----
- classBranch
- self
- shouldnt: [state isNil
- ifTrue: [self tell]
- ifFalse: [self class tell]]
- raise: MessageNotUnderstood!
Item was removed:
- CodeModelExtension subclass: #ProvidedSelectors
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Traits-Requires'!
Item was removed:
- ----- Method: CodeModelExtension>>clearOut: (in category 'access to cache') -----
- clearOut: aClass
- ^perClassCache removeKey: aClass ifAbsent: []!
Item was removed:
- ----- Method: TPureBehavior>>basicLocalSelectors (in category 'accessing method dictionary') -----
- basicLocalSelectors
- self explicitRequirement!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Behavior>>sendCaches (in category '*Traits-requires') -----
- sendCaches
- ^LocalSends current for: self!
Item was removed:
- ----- Method: TPureBehavior>>sendCaches (in category 'send caches') -----
- sendCaches
- ^ self explicitRequirement!
Item was removed:
- ----- 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!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: SendCaches>>superSenders: (in category 'accessing') -----
- superSenders: anObject
- ^superSenders := anObject!
Item was removed:
- ----- Method: RequiredSelectors>>lostOneInterestIn: (in category 'access to cache') -----
- lostOneInterestIn: aClass
- self lostInterest: nil in: aClass.
- !
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: Trait class>>initialize (in category 'class initialization') -----
- initialize "Trait initialize"
- "If no current trait implementation is installed yet, install myself."
- ClassDescription traitImpl
- ifNil:[ClassDescription traitImpl: self].!
Item was removed:
- ----- 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: $).!
Item was removed:
- ----- Method: RequiredSelectors>>dirtyWithChange: (in category 'as yet unclassified') -----
- dirtyWithChange: anEvent
- dirty := true.
- self dirtyClasses add: anEvent itemClass!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: TraitDescription>>printHierarchy (in category 'printing') -----
- printHierarchy
- "For hierarchy view in the browser; print the users of a trait"
- ^String streamContents:[:s| self printUsersOf: self on: s level: 0].!
Item was removed:
- ----- Method: TTestingDescription>>isClassSide (in category 'accessing parallel hierarchy') -----
- isClassSide
- ^self == self classSide!
Item was removed:
- ----- Method: RequirementsCache>>removeRequirement: (in category 'updates') -----
- removeRequirement: selector
- requirements ifNil: [^ self].
- requirements remove: selector ifAbsent: [].!
More information about the Packages
mailing list