Squeak-dev December 2009

squeak-dev@lists.squeakfoundation.org

97 participants
553 discussions

The Trunk: Traits-ar.261.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Traits to project The Trunk: http://source.squeak.org/trunk/Traits-ar.261.mcz ==================== Summary ==================== Name: Traits-ar.261 Author: ar Time: 30 December 2009, 2:36:09 am UUID: 79108af0-87db-b84b-839e-bdad931f5e94 Ancestors: Traits-ar.259 Revert the use of ClassTrait being the class of Trait. It causes problems when modifying class Trait itself since the subclass machinery isn't present and ClassBuilder is not ready for supporting alternative metaclasses in this form. =============== Diff against Traits-ar.256 =============== Item was added: + ClassDescription subclass: #TraitBehavior + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Kernel'! + + !TraitBehavior commentStamp: 'ar 12/29/2009 18:15' prior: 0! + Stub class for backward compatibility. Allows past extension methods in TraitBehavior to continue to work.! Item was added: + ----- Method: Trait>>removeFromSystem (in category 'initialize') ----- + removeFromSystem + self removeFromSystem: true! Item was added: + ----- Method: TraitDescription>>copy (in category 'copying') ----- + copy + self error: 'Traits cannot be trivially copied'! Item was added: + ----- Method: TraitExclusion>>- (in category 'converting') ----- + - anArrayOfSelectors + ^TraitExclusion + with: subject + exclusions: (anArrayOfSelectors, exclusions asArray)! Item was changed: ----- Method: Metaclass>>updateTraitsFrom: (in category '*Traits-NanoKernel') ----- updateTraitsFrom: instanceTraits "Update me from the given instance traits" | map newTraits trait | - ((instanceTraits isKindOf: NanoTraitComposition) or:[instanceTraits isEmpty]) - ifFalse:[self error: 'Invalid trait']. map := Dictionary new. self traitComposition isEmpty ifFalse:[ self traitComposition do:[:composed| map at: composed trait put: composed]. ]. newTraits := (instanceTraits collect:[:composed| trait := composed trait classTrait. map at: trait ifAbsent:[trait]]). self traitComposition isEmpty ifFalse:[ newTraits := newTraits, (self traitComposition select:[:comp| comp trait isBaseTrait]). ]. self installTraitsFrom: newTraits! Item was added: + ----- Method: TraitDescription>>+ (in category 'operations') ----- + + aTrait + "Creates a composition with the receiver and aTrait" + aTrait traitsDo:[:t| self == t ifTrue:[TraitCompositionException + signal: 'Trait ' , self asString, ' already in composition']]. + ^TraitComposition withAll: {self}, aTrait asTraitComposition! Item was added: + ----- Method: ClassTrait>>instanceSide (in category 'accessing') ----- + instanceSide + ^self baseTrait! Item was changed: + OrderedCollection subclass: #TraitComposition + instanceVariableNames: '' - Object subclass: #TraitComposition - instanceVariableNames: 'transformations' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! + !TraitComposition commentStamp: 'ar 12/29/2009 18:13' prior: 0! + A trait composition is a collection of Traits or TraitTransformations.! - !TraitComposition commentStamp: '<historical>' prior: 0! - I hold a collection of trait transformations and provide important facilities to query the trait composition. For each trait in the composition clause there exists exactly one transformation in the collection. - - Note, that directly manipulating the composition of a class or trait does not effect changes automatically. Use PureBehavior>>setTraitComposition: to do this. You have to make a copy of the old trait composition before changing it because only the difference between the new and the old composition is updated!!! Item was added: + ----- Method: ClassTrait>>soleInstance (in category 'accessing') ----- + soleInstance + ^baseTrait! Item was added: + ----- Method: TraitAlias>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + aliases := #().! Item was added: + ----- Method: TraitDescription>>addUser: (in category 'accessing') ----- + addUser: aTrait + ^self addTraitUser: aTrait! Item was changed: + ----- Method: TraitExclusion>>printOn: (in category 'composition') ----- - ----- Method: TraitExclusion>>printOn: (in category 'printing') ----- printOn: aStream + "Answer the trait composition string (used for class definitions)" + aStream nextPutAll: subject asString. + aStream nextPutAll: ' - {'. + exclusions asArray sort do:[:exc| aStream store: exc] separatedBy:[aStream nextPutAll: '. ']. + aStream nextPutAll: '}'.! - super printOn: aStream. - aStream - space; - nextPut: $-; - space; - nextPut: ${. - self exclusions do: [:each | aStream print: each] - separatedBy: [aStream nextPutAll: '. ']. - aStream nextPut: $}! Item was added: + ----- Method: TraitExclusion>>includesSelector: (in category 'composition') ----- + includesSelector: selector + "Answers true if the receiver provides the selector" + ^(subject includesSelector: selector) and:[(exclusions includes: selector) not]! Item was added: + ----- Method: Trait>>environment: (in category 'accessing') ----- + environment: anObject + environment := anObject! Item was added: + ----- Method: TraitDescription>>- (in category 'operations') ----- + - anArrayOfSelectors + "Creates an exclusion" + ^TraitExclusion + with: self + exclusions: anArrayOfSelectors! Item was added: + ----- Method: TraitTransformation>>isAliasSelector: (in category 'testing') ----- + isAliasSelector: selector + ^subject isAliasSelector: selector! Item was added: + ----- Method: TraitComposition>>addUser: (in category 'accessing') ----- + addUser: aUser + ^self addTraitUser: aUser! Item was added: + ----- Method: TraitTransformation>>allTraits (in category 'accessing') ----- + allTraits + ^subject allTraits! Item was added: + ----- Method: ClassTrait>>updateTraitsFrom: (in category 'initialize') ----- + updateTraitsFrom: instanceTraits + "Update me from the given instance traits" + | map newTraits trait | + map := Dictionary new. + self traitComposition do:[:composed| map at: composed trait put: composed]. + newTraits := (instanceTraits collect:[:composed| + trait := composed trait classTrait. + map at: trait ifAbsent:[trait]] + ), (self traitComposition select:[:comp| comp trait isBaseTrait]). + + self installTraitsFrom: newTraits! Item was added: + ----- Method: ClassTrait>>name (in category 'accessing') ----- + name + ^baseTrait name, ' classTrait'! Item was changed: TraitTransformation subclass: #TraitAlias instanceVariableNames: 'aliases' + classVariableNames: '' - classVariableNames: 'AliasMethodCache' poolDictionaries: '' category: 'Traits-Composition'! + !TraitAlias commentStamp: 'ar 12/29/2009 18:14' prior: 0! + A trait transformation representing the alias (->) operator.! - !TraitAlias commentStamp: '<historical>' prior: 0! - See comment of my superclass TraitTransformation.! Item was added: + ----- Method: TraitAlias>>@ (in category 'converting') ----- + @ anArrayOfAssociations + ^TraitAlias + with: subject + aliases: (anArrayOfAssociations, self aliases)! Item was added: + ----- Method: Trait>>theMetaClass (in category 'accessing') ----- + theMetaClass + ^self classTrait! Item was added: + ----- Method: TraitDescription>>removeUser: (in category 'accessing') ----- + removeUser: aTrait + ^self removeTraitUser: aTrait! Item was added: + ----- Method: TraitAlias>>initializeFrom: (in category 'initialize-release') ----- + initializeFrom: anArrayOfAssociations + | newNames | + newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. + newNames size < anArrayOfAssociations size ifTrue: [ + TraitCompositionException signal: 'Cannot use the same alias name twice']. + anArrayOfAssociations do: [:each | + (newNames includes: each value) ifTrue: [ + TraitCompositionException signal: 'Cannot define an alias for an alias']]. + aliases := anArrayOfAssociations. + ! Item was changed: + ----- Method: TraitTransformation>>@ (in category 'converting') ----- - ----- Method: TraitTransformation>>@ (in category 'composition') ----- @ anArrayOfAssociations + ^self subclassResponsibility! - TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'! Item was added: + ----- Method: TraitDescription class>>conflict:with:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: Trait>>definitionST80 (in category 'initialize') ----- + definitionST80 + ^String streamContents: [:stream | + stream nextPutAll: 'Trait named: '; + store: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + stream cr; tab; nextPutAll: 'category: '; + store: self category asString].! Item was added: + ----- Method: TraitComposition>>removeUser: (in category 'accessing') ----- + removeUser: aUser + ^self removeTraitUser: aUser! Item was added: + ----- Method: TraitDescription>>isTrait (in category 'testing') ----- + isTrait + ^true! Item was changed: ----- Method: ClassDescription>>resolveTraitsConflict:from:to: (in category '*Traits-NanoKernel') ----- resolveTraitsConflict: aSelector from: oldMethod to: newMethod "Resolve a traits conflict. Rules: - If one method is required the other one wins - Otherwise we compile a traits conflict " | marker selector | oldMethod methodHome == newMethod methodHome ifTrue:[^oldMethod]. marker := oldMethod markerOrNil. (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) ifTrue:[^newMethod]. marker := newMethod markerOrNil. (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) ifTrue:[^oldMethod]. "Create a conflict marker" selector := #(conflict conflict: conflict:with: conflict:with:with: conflict:with:with:with: conflict:with:with:with:with: conflict:with:with:with:with:with: conflict:with:with:with:with:with:with: conflict:with:with:with:with:with:with:with:) at: oldMethod numArgs+1. + ^TraitDescription class compiledMethodAt: selector.! - ^NanoTraitDescription class compiledMethodAt: selector.! Item was changed: ----- Method: TraitComposition>>asTraitComposition (in category 'converting') ----- asTraitComposition ^self! Item was added: + ----- Method: TraitDescription class>>conflict: (in category 'conflict methods') ----- + conflict: arg1 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: TraitTransformation>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with Trait" + ^true! Item was added: + ----- Method: TraitDescription>>traitComposition (in category 'accessing') ----- + traitComposition + ^traitComposition ifNil:[traitComposition := TraitComposition new] + ! Item was added: + Object subclass: #TraitTransformation + instanceVariableNames: 'subject users' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Composition'! + + !TraitTransformation commentStamp: 'ar 12/29/2009 18:14' prior: 0! + A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators. + + I define an instance variable named subject which holds the object that is transformed. Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents. + ! Item was added: + ----- Method: Trait>>environment (in category 'accessing') ----- + environment + ^environment! Item was added: + ----- Method: Trait>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- + fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex + super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. + self classSide hasMethods ifTrue:[ + aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. + self classSide + fileOutOn: aFileStream + moveSource: moveSource + toFile: fileIndex].! Item was added: + ----- Method: TraitTransformation>>traitsDo: (in category 'accessing') ----- + traitsDo: aBlock + ^subject traitsDo: aBlock! Item was added: + ----- Method: TraitDescription class>>conflict (in category 'conflict methods') ----- + conflict + "This method has a trait conflict" + ^self traitConflict! Item was changed: ----- Method: NanoTrait>>obsolete (in category 'initialize') ----- obsolete self name: ('AnObsolete' , self name) asSymbol. + self class obsolete. super obsolete! Item was changed: + ----- Method: TraitExclusion>>copyTraitExpression (in category 'composition') ----- - ----- Method: TraitExclusion>>copyTraitExpression (in category 'copying') ----- copyTraitExpression + "Copy all except the actual traits" + ^TraitExclusion + with: subject + exclusions: exclusions asArray! - ^super copyTraitExpression - exclusions: self exclusions deepCopy; - yourself! Item was added: + ----- Method: TraitTransformation>>isLocalAliasSelector: (in category 'testing') ----- + isLocalAliasSelector: selector + ^false! Item was added: + ----- Method: TraitTransformation>>updateTraits (in category 'operations') ----- + updateTraits + "Recompute my users traits composition" + users do:[:each| each updateTraits].! Item was added: + ----- Method: TraitDescription class>>conflict:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: Trait>>baseTrait (in category 'accessing') ----- + baseTrait + ^self! Item was added: + ----- Method: ClassTrait>>asMCDefinition (in category 'monticello') ----- + asMCDefinition + ^Smalltalk at: #MCClassTraitDefinition ifPresent:[:aClass| + aClass + baseTraitName: self baseTrait name + classTraitComposition: self traitCompositionString + ].! Item was added: + ----- Method: Trait>>classDefinitions (in category 'monticello') ----- + classDefinitions + | definitions | + definitions := OrderedCollection with: self asClassDefinition. + (self hasClassTrait + and: [self classTrait hasTraitComposition] + and: [self classTrait traitComposition isEmpty not]) + ifTrue: [definitions add: self classTrait asMCDefinition]. + ^definitions asArray! Item was added: + ----- Method: TraitDescription>>users: (in category 'accessing') ----- + users: aCollection + users := aCollection! Item was added: + ----- Method: Trait>>category (in category 'accessing') ----- + 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 | + category ifNotNilDo: [ :symbol | + ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) + ifTrue: [ ^symbol ] ]. + category := (result := SystemOrganization categoryOfElement: self name). + ^result! Item was added: + ----- Method: Trait>>asClassDefinition (in category 'monticello') ----- + asClassDefinition + ^Smalltalk at: #MCTraitDefinition ifPresent:[:aClass| + aClass + name: self name + traitComposition: self traitCompositionString + category: self category + comment: self organization classComment asString + commentStamp: self organization commentStamp].! Item was added: + ----- Method: TraitTransformation>>asTraitTransform (in category 'converting') ----- + asTraitTransform + ^self! Item was added: + ----- Method: TraitTransformation>>includesTrait: (in category 'testing') ----- + includesTrait: aTrait + ^subject includesTrait: aTrait! Item was changed: ----- Method: CompiledMethod>>originalTraitMethod: (in category '*Traits-NanoKernel') ----- originalTraitMethod: aCompiledMethod "Remember the original trait method for the receiver." | methodState | + methodState := TraitMethodState newFrom: self properties. - methodState := NanoTraitMethodState newFrom: self properties. methodState originalTraitMethod: aCompiledMethod. self penultimateLiteral: methodState.! Item was added: + ----- Method: TraitDescription>>copyTraitExpression (in category 'copying') ----- + copyTraitExpression + "Copy all except the actual traits" + ^self! Item was changed: + ----- Method: TraitTransformation>>trait (in category 'accessing') ----- - ----- Method: TraitTransformation>>trait (in category 'enquiries') ----- trait + ^subject trait! - ^self subject trait! Item was changed: ----- Method: TraitAlias>>aliases (in category 'accessing') ----- aliases "Collection of associations where key is the alias and value the original selector." - ^aliases! Item was added: + ----- Method: Trait class>>newTemplateIn: (in category 'public') ----- + newTemplateIn: categoryString + ^String streamContents: [:stream | + stream + nextPutAll: 'Trait named: #NameOfTrait'; + cr; tab; + nextPutAll: 'uses: {}'; + cr; tab; + nextPutAll: 'category: '; + nextPut: $'; + nextPutAll: categoryString; + nextPut: $' ]! Item was added: + ----- Method: TraitDescription>>users (in category 'accessing') ----- + users + ^users ifNil:[#()]! Item was added: + ----- Method: Trait class>>newTraitNamed:uses:category: (in category 'public') ----- + 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 added: + ----- Method: Trait class>>updateTraits: (in category 'class initialization') ----- + updateTraits: aCollection + "Convert all the traits in aCollection to NanoTraits. Used during installation." + "ClassDescription traitImpl: Trait. + Trait updateTraits:{ + TSequencedStreamTest. TGettableStreamTest. TReadStreamTest. + TStreamTest. TPuttableStreamTest. TWriteStreamTest + }" + | remain processed classes oldTrait classDef newTrait count instTraits classSelectors | + ClassDescription traitImpl == self ifFalse:[self error: 'What are you doing???']. + remain := (aCollection reject:[:tc| tc isKindOf: self]) asSet. + processed := Set new. + classes := Set new. + count := 0. + 'Converting ....' displayProgressAt: Sensor cursorPoint from: 1 to: remain size during:[:bar| + [remain isEmpty] whileFalse:[ + "Pick any trait whose traits are already converted" + oldTrait := remain detect:[:any| + any traitComposition traits allSatisfy:[:t| (Smalltalk at: t name) isKindOf: self]. + ] ifNone:[self error: 'Cannot convert cyclic traits']. + remain remove: oldTrait. + + bar value: (count := count +1). + ProgressNotification signal: '' extra: 'Converting ', oldTrait name. + + "Silently remove the old trait class and recreate it based on NanoTrait" + classDef := oldTrait definition. + Smalltalk removeKey: oldTrait name. + + "Create the NanoTrait from the same definition" + newTrait := Compiler evaluate: classDef. + + "Update comment" + oldTrait organization classComment ifNotEmpty:[ + newTrait classComment: oldTrait organization commentRemoteStr + stamp: oldTrait organization commentStamp. + ]. + + "Copy local methods to new trait" + oldTrait localSelectors do:[:sel| + newTrait + compile: (oldTrait sourceCodeAt: sel) + classified: (oldTrait organization categoryOfElement: sel) + withStamp: (oldTrait compiledMethodAt: sel) timeStamp + notifying: nil + ]. + oldTrait classSide localSelectors do:[:sel| + newTrait classSide + compile: (oldTrait classSide sourceCodeAt: sel) + classified: (oldTrait classSide organization categoryOfElement: sel) + withStamp: (oldTrait classSide compiledMethodAt: sel) timeStamp + notifying: nil + ]. + + newTrait selectors sort = oldTrait selectors sort + ifFalse:[self error: 'Something went VERY wrong']. + newTrait classSide selectors sort = oldTrait classSide selectors sort + ifFalse:[self error: 'Something went VERY wrong']. + + processed add: oldTrait. + classes addAll: (oldTrait users reject:[:aClass| aClass isObsolete]). + ]. + ]. + + classes := classes asArray select:[:cls| cls isKindOf: ClassDescription]. + 'Updating ....' displayProgressAt: Sensor cursorPoint from: 1 to: classes size during:[:bar| + "The traits are all converted, next update the classes" + classes keysAndValuesDo:[:index :aClass| + bar value: index. + ProgressNotification signal: '' extra: 'Updating ', aClass name. + + instTraits := Compiler evaluate: aClass traitComposition asString. + "Keep the local selectors from before" + localSelectors := aClass localSelectors. + classSelectors := aClass class localSelectors. + "Nuke the old traits composition" + aClass traitComposition: nil. + aClass class traitComposition: nil. + "Install the new one" + aClass uses: instTraits. + "Remove the old trait (now local) selectors" + (aClass selectors reject:[:sel| localSelectors includes: sel]) do:[:sel| + aClass removeSelectorSilently: sel. + (aClass includesSelector: sel) ifFalse:[self halt: 'Where is the code?']. + ]. + (aClass class selectors reject:[:sel| classSelectors includes: sel]) do:[:sel| + aClass class removeSelectorSilently: sel. + (aClass class includesSelector: sel) ifFalse:[self halt: 'Where is the code?']. + ]. + ]. + ]. + + "Finally, obsolete all the old traits" + processed do:[:trait| trait obsolete]. + ! Item was added: + ----- Method: NanoTrait>>asTraitComposition (in category 'converting') ----- + asTraitComposition + "Convert me into a trait composition" + ^TraitComposition with: self! Item was added: + ----- Method: TraitComposition>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + self do:[:each| each selectorsAndMethodsDo: aBlock].! Item was changed: + ----- Method: TraitComposition>>copyTraitExpression (in category 'operations') ----- - ----- Method: TraitComposition>>copyTraitExpression (in category 'copying') ----- copyTraitExpression + "Copy all except the actual traits" + ^self collect:[:each| each copyTraitExpression].! - | newCopy | - newCopy := self shallowCopy. - newCopy transformations: (self transformations collect: [ : each | each copyTraitExpression ]). - ^ newCopy - ! Item was added: + ----- Method: TraitDescription>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aTrait + users := self users copyWith: aTrait. + ! Item was added: + ----- Method: TraitComposition>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aUser + self do:[:each| each addTraitUser: aUser]! Item was added: + ----- Method: ClassTrait>>isClassTrait (in category 'testing') ----- + isClassTrait + ^true! Item was added: + ----- Method: Trait>>rename: (in category 'initialize') ----- + 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 added: + ----- Method: ClassTrait>>theMetaClass (in category 'accessing') ----- + theMetaClass + ^self! Item was changed: ----- Method: NanoClassTrait>>uses: (in category 'initialize') ----- uses: aTraitComposition | newTraits | + newTraits := aTraitComposition asTraitComposition. - newTraits := (aTraitComposition isTrait or:[aTraitComposition isTraitTransformation]) - ifTrue:[NanoTraitComposition with: aTraitComposition] - ifFalse:[(aTraitComposition isKindOf: SequenceableCollection) - ifTrue:[NanoTraitComposition withAll: aTraitComposition asArray] - ifFalse:[self error: 'Invalid traits specification']]. newTraits traitsDo:[:t| (t isBaseTrait and:[t classSide hasMethods]) ifTrue:[self error: 'Cannot add: ', t]. (t isClassTrait and:[(baseTrait includesTrait: t baseTrait) not]) ifTrue:[self error: 'Cannot add: ', t]. ]. self installTraitsFrom: newTraits.! Item was added: + ----- Method: Trait>>bindingOf: (in category 'compiling') ----- + bindingOf: varName + "Answer the binding of some variable resolved in the scope of the receiver" + ^self environment bindingOf: varName asSymbol.! Item was added: + ----- Method: TraitExclusion>>@ (in category 'converting') ----- + @ anArrayOfAssociations + + TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.' + ! Item was added: + ----- Method: ClassTrait>>definitionST80 (in category 'accessing') ----- + definitionST80 + ^String streamContents: [:stream | + stream nextPutAll: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + ].! Item was added: + ----- Method: TraitMethodState>>methodHome (in category 'accessing') ----- + methodHome + "The behavior (trait/class) this method was originally defined in. + Derived from the originalTraitMethod if any." + ^originalTraitMethod ifNil:[super methodHome] ifNotNil:[:m| m methodHome]! Item was added: + ----- Method: Trait>>obsolete (in category 'initialize') ----- + obsolete + self name: ('AnObsolete' , self name) asSymbol. + self classTrait obsolete. + super obsolete! Item was added: + ----- Method: Trait>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + classTrait := ClassTrait for: self.! Item was added: + ----- Method: TraitDescription>>notifyOfRecategorizedSelector:from:to: (in category 'operations') ----- + notifyOfRecategorizedSelector: element from: oldCategory to: newCategory + super notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. + self users do:[:each| each classify: element under: newCategory from: oldCategory trait: self].! Item was added: + ----- Method: TraitDescription>>traitComposition: (in category 'accessing') ----- + traitComposition: aTraitComposition + traitComposition := aTraitComposition. + ! Item was changed: + ----- Method: TraitComposition>>+ (in category 'converting') ----- + + aTrait + self traitsDo:[:t| (t == aTrait trait) ifTrue:[^TraitCompositionException + signal: 'Trait ' , aTrait trait asString, ' already in composition']]. + self addLast: aTrait. + ^self! - ----- Method: TraitComposition>>+ (in category 'composition') ----- - + aTraitExpression - ^ aTraitExpression addCompositionOnLeft: self. - ! Item was added: + ----- Method: TraitTransformation>>initialize (in category 'initialize') ----- + initialize + super initialize. + users := #().! Item was added: + ----- Method: TraitDescription>>isClassTrait (in category 'testing') ----- + isClassTrait + ^false! Item was added: + ----- Method: TraitDescription>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aTrait + users := self users copyWithout: aTrait. + ! Item was changed: TraitTransformation subclass: #TraitExclusion instanceVariableNames: 'exclusions' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! + !TraitExclusion commentStamp: 'ar 12/29/2009 18:13' prior: 0! + A trait transformation representing the exclusion (-) operator.! - !TraitExclusion commentStamp: '<historical>' prior: 0! - See comment of my superclass TraitTransformation.! Item was added: + ----- Method: Trait class>>named:uses:category: (in category 'public') ----- + named: aSymbol uses: aTraitCompositionOrCollection category: aString + "Dispatch through ClassDescription for alternative implementations" + ^ClassDescription newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString! Item was changed: ----- Method: ClassDescription>>localSelectors (in category '*Traits-NanoKernel') ----- localSelectors + ^self selectors select:[:sel| self includesLocalSelector: sel]! - ^(self traitComposition isKindOf: NanoTraitComposition) - ifTrue:[self selectors select:[:sel| self includesLocalSelector: sel]] - ifFalse:[super localSelectors]. - ! Item was changed: + ----- Method: TraitComposition>>isAliasSelector: (in category 'operations') ----- + isAliasSelector: selector + "enumerates all selectors and methods in a trait composition" + ^self anySatisfy:[:any| any isAliasSelector: selector]! - ----- Method: TraitComposition>>isAliasSelector: (in category 'testing') ----- - isAliasSelector: aSymbol - "Return true if the selector aSymbol is an alias defined - in this or in another composition somewhere deeper in - the tree of traits compositions." - - | methodDescription | - methodDescription := (self methodDescriptionsForSelector: aSymbol) - detect: [:each | each selector = aSymbol]. - ^methodDescription isAliasSelector! Item was added: + ----- Method: TraitDescription>>@ (in category 'operations') ----- + @ anArrayOfAssociations + "Creates an alias" + ^TraitAlias with: self aliases: anArrayOfAssociations! Item was changed: ----- Method: TraitComposition>>allTraits (in category 'accessing') ----- allTraits + ^self gather:[:each| each allTraits copyWith: each trait]! - ^self traits gather: [:trait | - trait hasTraitComposition - ifTrue: [trait traitComposition allTraits copyWith: trait] - ifFalse: [Array with: trait]]! Item was changed: + ----- Method: TraitComposition>>- (in category 'converting') ----- - ----- Method: TraitComposition>>- (in category 'composition') ----- - anArray "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand" + self addLast: (self removeLast - anArray)! - self transformations - addLast: (self transformations removeLast - anArray)! Item was changed: ----- Method: TraitComposition>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aUser + self do:[:each| each removeTraitUser: aUser]! - removeTraitUser: aClass - self traits do:[:each| each removeUser: aClass].! Item was added: + ----- Method: Trait>>isBaseTrait (in category 'testing') ----- + isBaseTrait + ^true! Item was added: + ----- Method: ClassTrait>>theNonMetaClass (in category 'accessing') ----- + theNonMetaClass + "Sent to a class or metaclass, always return the class" + ^baseTrait! Item was added: + ----- Method: ClassTrait>>baseTrait (in category 'accessing') ----- + baseTrait + ^baseTrait! Item was added: + ----- Method: Trait class>>newTraitComposition (in category 'public') ----- + newTraitComposition + "Creates a new TraitComposition" + ^TraitComposition new! Item was changed: + ----- Method: TraitAlias>>printOn: (in category 'operations') ----- + printOn: s + "Answer the trait composition string (used for class definitions)" + s nextPutAll: subject asString. + s nextPutAll: ' @ {'. + aliases do:[:assoc| s print: assoc] separatedBy:[s nextPutAll:'. ']. + s nextPutAll: '}'. + ! - ----- Method: TraitAlias>>printOn: (in category 'printing') ----- - printOn: aStream - super printOn: aStream. - aStream - space; - nextPut: $@; - space; - nextPut: ${. - self aliases do: [:each | aStream print: each] - separatedBy: [aStream nextPutAll: '. ']. - aStream nextPut: $}! Item was added: + ----- Method: Trait>>asTraitComposition (in category 'converting') ----- + asTraitComposition + "Convert me into a trait composition" + ^TraitComposition with: self! Item was added: + ----- Method: Trait class>>named:uses:category:env: (in category 'instance creation') ----- + named: aSymbol uses: aTraitComposition category: aString env: anEnvironment + | trait oldTrait systemCategory oldCategory | + systemCategory := aString asSymbol. + oldTrait := anEnvironment at: aSymbol ifAbsent: [nil]. + oldTrait ifNil:[ + trait := Trait new. + ] ifNotNil:[ + oldCategory := oldTrait category. + trait := oldTrait. + ]. + (trait isMemberOf: Trait) ifFalse: [ + ^self error: trait name , ' is not a Trait']. + trait + setName: aSymbol + andRegisterInCategory: systemCategory + environment: anEnvironment. + + trait uses: aTraitComposition. + + "... notify interested clients ..." + oldTrait ifNil:[ + SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory. + ] ifNotNil:[ + systemCategory = oldCategory ifFalse:[ + SystemChangeNotifier uniqueInstance class: trait + recategorizedFrom: oldTrait category to: systemCategory]. + ]. + ^ trait! Item was added: + ----- Method: TraitTransformation>>asTraitComposition (in category 'converting') ----- + asTraitComposition + ^TraitComposition with: self! Item was changed: ----- Method: ClassDescription>>updateTraits (in category '*Traits-NanoKernel') ----- updateTraits "Recompute my local traits composition" + self installTraitsFrom: self traitComposition. - (self traitComposition isKindOf: NanoTraitComposition) - ifTrue:[self installTraitsFrom: self traitComposition]. ! Item was changed: + ----- Method: TraitComposition>>printOn: (in category 'converting') ----- - ----- Method: TraitComposition>>printOn: (in category 'printing') ----- printOn: aStream + "Answer the trait composition string (used for class definitions)" + aStream nextPutAll: self traitCompositionString. + ! - self transformations isEmptyOrNil - ifFalse: [ - self transformations - do: [:each | aStream print: each] - separatedBy: [aStream nextPutAll: ' + '] ] - ifTrue: [aStream nextPutAll: '{}'] - ! Item was added: + ----- Method: TraitDescription>>traitsDo: (in category 'operations') ----- + traitsDo: aBlock + aBlock value: self.! Item was added: + ----- Method: TraitMethodState>>originalTraitMethod: (in category 'accessing') ----- + originalTraitMethod: aCompiledMethod + "The original method from the trait" + originalTraitMethod := aCompiledMethod! Item was changed: ----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') ----- installTraitsFrom: aTraitComposition "Install the traits from the given composition" | allTraits methods oldMethod removals oldCategories | + - (aTraitComposition isKindOf: NanoTraitComposition) - ifFalse:[self error: 'Invalid composition']. (self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self]. "Check for cycles" allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t]. (allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected']. "XXXX: addUser/removeUser should be part of setter, but subclass override prevents it until we've got rid of Traits mess." self traitComposition removeTraitUser: self. self traitComposition: aTraitComposition. aTraitComposition addTraitUser: self. "Assemble the methods in a new dictionary first. Uses a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)" methods := Dictionary new. "Stick in the local methods first, since this avoids generating conflict methods unnecessarily" self selectorsAndMethodsDo:[:sel :newMethod| (self isLocalMethod: newMethod) ifTrue:[methods at: sel put:newMethod]]. "Now assemble the traits methods" aTraitComposition do:[:trait| trait selectorsAndMethodsDo:[:sel :newMethod| oldMethod := methods at: sel ifAbsentPut:[newMethod]. newMethod == oldMethod ifFalse:["a conflict" (self isLocalMethod: oldMethod) ifFalse:[ methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod). ]. ]. ]. ]. "Apply the changes. We first add the new or changed methods." oldCategories := Set new. methods keysAndValuesDo:[:sel :newMethod| oldMethod := self compiledMethodAt: sel ifAbsent:[nil]. oldMethod == newMethod ifFalse:[ self traitAddSelector: sel withMethod: newMethod. (self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat]. self organization classify: sel under: (newMethod methodHome organization categoryOfElement: newMethod selector). ]]. "Now remove the old or obsoleted ones" removals := OrderedCollection new. self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]]. removals do:[:sel| self traitRemoveSelector: sel]. "Clean out empty categories" oldCategories do:[:cat| (self organization isEmptyCategoryNamed: cat) ifTrue:[self organization removeCategory: cat]]. + self isMeta ifFalse:[self classSide updateTraitsFrom: aTraitComposition].! - self isMeta ifFalse:[self class updateTraitsFrom: aTraitComposition].! Item was added: + ----- Method: TraitComposition>>traitsDo: (in category 'accessing') ----- + traitsDo: aBlock + ^self do:[:each| each traitsDo: aBlock]! Item was added: + ----- Method: Trait>>isObsolete (in category 'testing') ----- + isObsolete + "Return true if the receiver is obsolete." + ^(self environment at: name ifAbsent: [nil]) ~~ self! Item was added: + ----- Method: TraitDescription>>allClassVarNames (in category 'accessing') ----- + allClassVarNames + "Traits have no class var names" + ^#()! Item was changed: + ----- Method: TraitComposition>>isLocalAliasSelector: (in category 'operations') ----- + isLocalAliasSelector: selector + "Return true if the selector aSymbol is an alias defined in the receiver." + ^self anySatisfy:[:any| any isTraitTransformation and:[any isLocalAliasSelector: selector]]! - ----- Method: TraitComposition>>isLocalAliasSelector: (in category 'testing') ----- - isLocalAliasSelector: aSymbol - "Return true if the selector aSymbol is an alias defined - in this composition." - - | methodDescription | - methodDescription := (self methodDescriptionsForSelector: aSymbol) - detect: [:each | each selector = aSymbol]. - ^methodDescription isLocalAliasSelector! Item was added: + ----- Method: Trait>>definition (in category 'initialize') ----- + definition + ^String streamContents: [:stream | + stream nextPutAll: 'Trait named: '; + store: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + stream cr; tab; nextPutAll: 'category: '; + store: self category asString].! Item was added: + ----- Method: Trait>>removeFromSystem: (in category 'initialize') ----- + removeFromSystem: logged + self environment forgetClass: self logged: logged. + self obsolete! Item was added: + AdditionalMethodState variableSubclass: #TraitMethodState + instanceVariableNames: 'originalTraitMethod' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Kernel'! + + !TraitMethodState commentStamp: 'ar 12/29/2009 18:13' prior: 0! + Additional method state for trait provided methods.! Item was added: + ----- Method: ClassTrait>>baseTrait: (in category 'accessing') ----- + baseTrait: aTrait + baseTrait ifNotNil:[self error: 'Already initialized']. + baseTrait := aTrait.! Item was added: + ----- Method: TraitDescription>>includesTrait: (in category 'testing') ----- + includesTrait: aTrait + ^self == aTrait or:[super includesTrait: aTrait]! Item was added: + TraitDescription subclass: #ClassTrait + instanceVariableNames: 'baseTrait' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Kernel'! + + !ClassTrait commentStamp: 'ar 12/29/2009 18:16' prior: 0! + The class of some trait. Just like the Class - Metaclass relationship.! Item was added: + ----- Method: TraitDescription>>trait (in category 'accessing') ----- + trait + ^self! Item was changed: ----- Method: TraitComposition>>includesTrait: (in category 'testing') ----- includesTrait: aTrait + ^self anySatisfy:[:each| each includesTrait: aTrait]! - ^self traits includes: aTrait! Item was added: + ----- Method: TraitDescription class>>conflict:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: TraitAlias>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + subject selectorsAndMethodsDo:[:sel :meth| + aBlock value: sel value: meth. + ]. + aliases do:[:assoc| | method | + "Method can be nil during removals" + method := subject compiledMethodAt: assoc value ifAbsent:[nil]. + method ifNotNil:[aBlock value: assoc key value: method]. + ].! Item was changed: + ----- Method: TraitAlias>>copyTraitExpression (in category 'operations') ----- - ----- Method: TraitAlias>>copyTraitExpression (in category 'copying') ----- copyTraitExpression + "Copy all except the actual traits" + ^TraitAlias + with: subject + aliases: aliases! - ^super copyTraitExpression - aliases: self aliases deepCopy; - yourself! Item was added: + ----- Method: ClassTrait>>bindingOf: (in category 'compiling') ----- + bindingOf: varName + "Answer the binding of some variable resolved in the scope of the receiver" + ^baseTrait bindingOf: varName! Item was added: + ----- Method: TraitDescription class>>conflict:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 + "This method has a trait conflict" + ^self traitConflict! Item was changed: + ----- Method: TraitComposition>>removeFromComposition: (in category 'compat') ----- - ----- Method: TraitComposition>>removeFromComposition: (in category 'accessing') ----- removeFromComposition: aTrait + "--- ignore ---"! - self remove: - (self transformationOfTrait: aTrait)! Item was added: + TraitDescription subclass: #Trait + instanceVariableNames: 'name environment classTrait category' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Kernel'! + + !Trait commentStamp: 'ar 12/29/2009 18:16' prior: 0! + Defines a trait in the system. Like Class, I concretize my superclass by providing instance variables for the name and the environment.! Item was added: + ----- Method: TraitExclusion>>initialize (in category 'initialize') ----- + initialize + super initialize. + exclusions := Set new. + ! Item was added: + ----- Method: ClassTrait>>uses: (in category 'initialize') ----- + uses: aTraitComposition + | newTraits | + newTraits := aTraitComposition asTraitComposition. + newTraits traitsDo:[:t| + (t isBaseTrait and:[t classSide hasMethods]) + ifTrue:[self error: 'Cannot add: ', t]. + (t isClassTrait and:[(baseTrait includesTrait: t baseTrait) not]) + ifTrue:[self error: 'Cannot add: ', t]. + ]. + self installTraitsFrom: newTraits.! Item was added: + ----- Method: Trait>>isValidTraitName: (in category 'initialize') ----- + isValidTraitName: aSymbol + ^(aSymbol isEmptyOrNil + or: [aSymbol first isLetter not] + or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! Item was added: + ----- Method: ClassTrait>>classSide (in category 'accessing') ----- + classSide + ^self! Item was added: + ----- Method: Trait class>>allTraitsDo: (in category 'public') ----- + allTraitsDo: aBlock + "Evaluate aBlock with all the instance and class traits present in the system" + Trait allInstances do: [:aTrait| + aBlock value: aTrait instanceSide. + aBlock value: aTrait classSide. + ].! Item was added: + ----- Method: Trait>>hasClassTrait (in category 'testing') ----- + hasClassTrait + ^true! Item was added: + ----- Method: ClassTrait>>isMeta (in category 'testing') ----- + isMeta + ^true! Item was added: + TraitBehavior subclass: #TraitDescription + instanceVariableNames: 'users traitComposition' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-Kernel'! + + !TraitDescription commentStamp: 'ar 12/29/2009 18:15' prior: 0! + TraitDescription combines common behavior for both (instance) traits and (meta) class traits.! Item was changed: ----- Method: ClassDescription>>uses: (in category '*Traits-NanoKernel') ----- uses: aTraitComposition + + self installTraitsFrom: aTraitComposition asTraitComposition. - | newTraits | - newTraits := (aTraitComposition isKindOf: NanoTrait orOf: NanoTraitTransformation) - ifTrue:[NanoTraitComposition with: aTraitComposition] - ifFalse:[(aTraitComposition isKindOf: SequenceableCollection) - ifTrue:[NanoTraitComposition withAll: aTraitComposition asArray] - ifFalse:[self error: 'Invalid traits specification']]. - self installTraitsFrom: newTraits. ! Item was changed: ----- Method: TraitExclusion>>exclusions (in category 'accessing') ----- exclusions ^exclusions! Item was added: + ----- Method: TraitTransformation>>+ (in category 'converting') ----- + + aTrait + "Just like ordered collection" + ^TraitComposition withAll: {self. aTrait}! Item was added: + ----- Method: ClassTrait class>>for: (in category 'instance creation') ----- + for: baseTrait + ^self new baseTrait: baseTrait! Item was changed: ----- Method: TraitTransformation>>subject: (in category 'accessing') ----- + subject: aSubject + subject := aSubject.! - subject: aTraitTransformation - subject := aTraitTransformation! Item was added: + ----- Method: TraitAlias>>isAliasSelector: (in category 'testing') ----- + isAliasSelector: selector + ^(self isLocalAliasSelector: selector) or:[super isAliasSelector: selector]! Item was added: + ----- Method: Trait>>setName:andRegisterInCategory:environment: (in category 'initialize') ----- + setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary + (self isValidTraitName: aSymbol) ifFalse: [self error:'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: [self error: '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 added: + ----- Method: TraitDescription>>sharedPools (in category 'accessing') ----- + sharedPools + "Traits have no shared pools" + ^ Dictionary new! Item was changed: + ----- Method: TraitAlias>>- (in category 'converting') ----- - ----- Method: TraitAlias>>- (in category 'composition') ----- - anArrayOfSelectors ^TraitExclusion with: self exclusions: anArrayOfSelectors! Item was changed: ----- Method: TraitAlias class>>with:aliases: (in category 'instance creation') ----- with: aTraitComposition aliases: anArrayOfAssociations self assertValidAliasDefinition: anArrayOfAssociations. ^self new subject: aTraitComposition; + initializeFrom: anArrayOfAssociations; - aliases: anArrayOfAssociations; yourself! Item was added: + ----- Method: TraitComposition>>traitCompositionString (in category 'operations') ----- + traitCompositionString + "Answer the trait composition string (used for class definitions)" + self size = 0 ifTrue:[^'{}']. + self size = 1 ifTrue:[^self first asString]. + ^String streamContents:[:s| + self do:[:each| s nextPutAll: each asString] separatedBy:[s nextPutAll: ' + ']. + ].! Item was added: + ----- Method: Trait class>>install (in category 'class initialization') ----- + install + "Trait install" + ClassDescription traitImpl: self. "Create all new traits as NanoTraits" + self updateTraits: Smalltalk allTraits. "And convert everything to NanoTraits" + "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. + Smalltalk allClassesAndTraits do:[:cls | | tc | + ((tc := cls traitComposition) isKindOf: TraitComposition) + ifFalse:[cls traitComposition: (TraitComposition withAll: tc)]. + ((tc := cls class traitComposition) isKindOf: TraitComposition) + ifFalse:[cls class traitComposition: (TraitComposition withAll: tc)]. + ].! Item was added: + ----- Method: TraitDescription>>isBaseTrait (in category 'testing') ----- + isBaseTrait + ^false! Item was added: + ----- Method: TraitTransformation>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aTrait + users := users copyWithout: aTrait. + subject removeTraitUser: aTrait.! Item was changed: + ----- Method: TraitTransformation>>- (in category 'converting') ----- + - anArrayOfSelectors + ^self subclassResponsibility! - ----- Method: TraitTransformation>>- (in category 'composition') ----- - - anArray - TraitCompositionException signal: 'Invalid trait exclusion. Exclusions have to be specified after aliases.'! Item was added: + ----- Method: Trait>>classTrait (in category 'accessing') ----- + classTrait + ^classTrait! Item was added: + ----- Method: Trait>>category: (in category 'accessing') ----- + category: aString + "Categorize the receiver under the system category, aString, removing it from + any previous categorization." + + | oldCategory | + oldCategory := category. + aString isString + ifTrue: [ + category := aString asSymbol. + SystemOrganization classify: self name under: category ] + ifFalse: [self errorCategoryName]. + SystemChangeNotifier uniqueInstance + class: self recategorizedFrom: oldCategory to: category! Item was added: + ----- Method: ClassTrait>>definition (in category 'accessing') ----- + definition + ^String streamContents: [:stream | + stream nextPutAll: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + ].! Item was added: + ----- Method: TraitDescription class>>conflict:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: TraitDescription>>asTraitComposition (in category 'converting') ----- + asTraitComposition + ^TraitComposition with: self! Item was changed: + ----- Method: TraitComposition>>@ (in category 'converting') ----- - ----- Method: TraitComposition>>@ (in category 'composition') ----- @ anArrayOfAssociations "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand" + self addLast: (self removeLast @ anArrayOfAssociations)! - self transformations - addLast: (self transformations removeLast @ anArrayOfAssociations)! Item was added: + ----- Method: TraitDescription>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with TraitTransformation" + ^false! Item was added: + ----- Method: TraitAlias>>includesSelector: (in category 'operations') ----- + includesSelector: selector + "Answers true if the receiver provides the selector" + ^(subject includesSelector: selector) or:[aliases anySatisfy:[:assoc| assoc key == selector]]! Item was added: + ----- 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 added: + ----- Method: Trait>>name: (in category 'accessing') ----- + name: aSymbol + name := aSymbol! Item was added: + ----- 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: aClass on: aStream level: indent+1]. + ]. + ! Item was added: + ----- Method: TraitComposition>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with TraitTransformation" + ^false! Item was changed: ----- Method: TraitAlias>>aliases: (in category 'accessing') ----- + aliases: aCollection + "Collection of associations where key is the + alias and value the original selector." + aliases := aCollection! - aliases: anArrayOfAssociations - | newNames | - newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. - newNames size < anArrayOfAssociations size ifTrue: [ - TraitCompositionException signal: 'Cannot use the same alias name twice']. - anArrayOfAssociations do: [:each | - (newNames includes: each value) ifTrue: [ - TraitCompositionException signal: 'Cannot define an alias for an alias']]. - aliases := anArrayOfAssociations! Item was added: + ----- Method: TraitAlias>>isLocalAliasSelector: (in category 'testing') ----- + isLocalAliasSelector: selector + ^(aliases anySatisfy:[:assoc| assoc key == selector])! Item was changed: ----- Method: TraitExclusion class>>with:exclusions: (in category 'instance creation') ----- with: aTraitComposition exclusions: anArrayOfSelectors ^self new subject: aTraitComposition; exclusions: anArrayOfSelectors; yourself ! Item was added: + ----- Method: TraitMethodState>>originalTraitMethod (in category 'accessing') ----- + originalTraitMethod + "The original method from the trait" + ^originalTraitMethod! Item was added: + ----- Method: TraitDescription class>>conflict:with:with:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: TraitDescription>>classPool (in category 'accessing') ----- + classPool + "Traits have no class pool" + ^ Dictionary new! Item was added: + ----- Method: TraitExclusion>>selectorsAndMethodsDo: (in category 'composition') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + ^subject selectorsAndMethodsDo:[:sel :meth| + (exclusions includes: sel) ifFalse:[aBlock value: sel value: meth]. + ].! Item was added: + ----- Method: Trait>>name (in category 'accessing') ----- + name + ^name! Item was added: + ----- Method: TraitDescription>>installTraitsFrom: (in category 'operations') ----- + installTraitsFrom: aTraitComposition + super installTraitsFrom: aTraitComposition. + self users do:[:each| each updateTraits].! Item was added: + ----- Method: TraitMethodState>>originalTraitOrClass (in category 'accessing') ----- + originalTraitOrClass + "The original trait for this method" + ^originalTraitMethod originalTraitOrClass! Item was changed: ----- Method: TraitAlias class>>assertValidAliasDefinition: (in category 'instance creation') ----- assertValidAliasDefinition: anArrayOfAssociations "Throw an exceptions if the alias definition is not valid. It is expected to be a collection of associations and the number of arguments of the alias selector has to be the same as the original selector." ((anArrayOfAssociations isKindOf: Collection) and: [ anArrayOfAssociations allSatisfy: [:each | each isKindOf: Association]]) ifFalse: [ + self error: 'Invalid alias definition: Not a collection of associations.']. - TraitCompositionException signal: 'Invalid alias definition: Not a collection of associations.']. (anArrayOfAssociations allSatisfy: [:association | (association key numArgs = association value numArgs and: [ (association key numArgs = -1) not])]) ifFalse: [ TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! Item was added: + ----- Method: TraitDescription>>addSelectorSilently:withMethod: (in category 'operations') ----- + addSelectorSilently: selector withMethod: compiledMethod + "Overridden to update the users of this trait" + super addSelectorSilently: selector withMethod: compiledMethod. + self users do:[:each| each updateTraits].! Item was added: + ----- Method: TraitTransformation>>updateSelector:withTraitMethod:from: (in category 'operations') ----- + updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait + "broadcasts the change of a selector to all users of a trait" + ^self subclassResponsibility! Item was added: + ----- Method: TraitDescription>>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 added: + ----- Method: TraitTransformation>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + ^self subclassResponsibility! Item was changed: + ----- Method: TraitTransformation>>copyTraitExpression (in category 'operations') ----- - ----- Method: TraitTransformation>>copyTraitExpression (in category 'copying') ----- copyTraitExpression + "Copy all except the actual traits" + ^self subclassResponsibility! - ^self shallowCopy - subject: self subject copyTraitExpression; - yourself! Item was changed: ----- Method: TraitComposition>>traits (in category 'accessing') ----- traits + ^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]! - ^self transformations collect: [:each | - each trait]! Item was added: + ----- Method: Trait class>>initialize (in category 'class initialization') ----- + initialize + "Trait initialize" + self install.! Item was added: + ----- 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 added: + ----- Method: TraitTransformation>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aTrait + users := users copyWith: aTrait. + subject addTraitUser: aTrait. + ! Item was changed: + Error subclass: #TraitCompositionException - TraitException subclass: #TraitCompositionException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'! + !TraitCompositionException commentStamp: 'ar 12/29/2009 18:13' prior: 0! + Signals invalid trait compositions.! - !TraitCompositionException commentStamp: '<historical>' prior: 0! - Signal invalid trait compositions.! Item was changed: ----- Method: TraitExclusion>>exclusions: (in category 'accessing') ----- exclusions: aCollection + exclusions := Set withAll: aCollection! - exclusions := aCollection! Item was added: + ----- Method: TraitDescription class>>conflict:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 + "This method has a trait conflict" + ^self traitConflict! Item was removed: - ----- Method: TraitMethodDescription class>>new (in category 'instance creation') ----- - new - ^super new - initialize; - yourself! Item was removed: - ----- Method: TraitComposition>>printString (in category 'printing') ----- - printString - ^String streamContents: [:stream | - self printOn: stream]! Item was removed: - ----- Method: TraitComposition>>copy (in category 'copying') ----- - copy - self error: 'should not be called'. - ^super copy - transformations: (self transformations collect: [:each | each copy]); - yourself! Item was removed: - ----- Method: TraitComposition>>asArray (in category 'converting') ----- - asArray - ^self transformations asArray! Item was removed: - ----- Method: TraitComposition>>errorIfNotAddable: (in category 'error-handling') ----- - errorIfNotAddable: aTraitTransformation - (self includesTrait: aTraitTransformation trait) ifTrue: [ - ^TraitCompositionException - signal: 'Trait ' , aTraitTransformation trait asString, ' already in composition']! Item was removed: - ----- Method: TraitAlias>>allAliasesDict (in category 'enquiries') ----- - allAliasesDict - | dict | - dict := super allAliasesDict. - self aliases do: [:assoc | - dict at: assoc key put: assoc value]. - ^dict! Item was removed: - ----- Method: TraitMethodDescription>>size (in category 'accessing') ----- - size - ^self locatedMethods size! Item was removed: - ----- Method: TraitComposition>>methodDescriptionForSelector: (in category 'enquiries') ----- - methodDescriptionForSelector: aSymbol - "Return a TraitMethodDescription for the selector aSymbol." - - | description | - description := TraitMethodDescription selector: aSymbol. - self transformations do: [:each | - each collectMethodsFor: aSymbol into: description]. - ^description! Item was removed: - ----- Method: TraitMethodDescription>>isEmpty (in category 'testing') ----- - isEmpty - ^self size = 0! Item was removed: - ----- Method: TraitTransformation>>allAliasesDict (in category 'enquiries') ----- - allAliasesDict - "Return a dictionary with all alias associations that are defined in this transformation." - - ^self subject allAliasesDict! Item was removed: - ----- Method: TraitComposition>>assertValidUser: (in category 'error-handling') ----- - assertValidUser: aBehavior - "Assert that this trait composition set for aBehavior - does not introduce a cycle." - - (self allTraits includes: aBehavior) ifTrue: [ - TraitCompositionException signal: 'Cycle in compositions: The composition (in)directly includes this trait!!']! Item was removed: - ----- Method: TraitComposition>>includesMethod: (in category 'testing') ----- - includesMethod: aSelector - ^(self methodDescriptionForSelector: aSelector) isEmpty not! Item was removed: - ----- Method: TraitAlias>>allSelectors (in category 'enquiries') ----- - allSelectors - ^self subject allSelectors - addAll: (self aliases collect: [:each | each key]) asSet; - yourself! Item was removed: - ----- Method: TraitExclusion>>isEmpty (in category 'testing') ----- - isEmpty - ^self exclusions isEmpty! Item was removed: - ----- Method: TraitTransformation>>subject (in category 'accessing') ----- - subject - ^subject! Item was removed: - ----- Method: TraitTransformation>>allSelectors (in category 'enquiries') ----- - allSelectors - ^self subclassResponsibility! Item was removed: - ----- Method: TraitExclusion>>addExclusionOf: (in category 'composition') ----- - addExclusionOf: aSymbol - self exclusions: (self exclusions copyWith: aSymbol)! Item was removed: - ----- Method: TraitComposition>>methodDescriptionsForSelector: (in category 'enquiries') ----- - methodDescriptionsForSelector: aSymbol - "Return a collection of TraitMethodDescriptions for aSymbol and all the - aliases of aSymbol." - - | selectors collection | - selectors := IdentitySet with: aSymbol. - self transformations do: [:each | - selectors addAll: (each aliasesForSelector: aSymbol)]. - collection := OrderedCollection new: selectors size. - selectors do: [:each | - collection add: (self methodDescriptionForSelector: each)]. - ^collection! Item was removed: - ----- Method: TraitMethodDescription>>isProvided (in category 'testing') ----- - isProvided - ^ self providedMethod notNil! Item was removed: - ----- Method: TraitComposition>>size (in category 'accessing') ----- - size - ^transformations size! Item was removed: - ----- Method: TraitComposition>>isEmpty (in category 'testing') ----- - isEmpty - ^self transformations isEmpty! Item was removed: - ----- Method: TraitComposition>>transformations (in category 'accessing') ----- - transformations - ^transformations! Item was removed: - ----- Method: TraitMethodDescription>>isLocalAliasSelector (in category 'testing') ----- - isLocalAliasSelector - "Return true if the selector is an alias (if it is different - from the original selector). Return false, if not or if we - have a conflict." - - ^self size = 1 and: [ - (self locatedMethods anyOne selector ~= self selector)]! Item was removed: - ----- Method: TraitMethodDescription>>generateTemplateMethodWithMarker:forArgs:binary: (in category 'private') ----- - generateTemplateMethodWithMarker: aSymbol forArgs: aNumber binary: aBoolean - | source node | - source := String streamContents: [:stream | - aNumber < 1 - ifTrue: [stream nextPutAll: 'selector'] - ifFalse: [aBoolean - ifTrue: [ - stream nextPutAll: '* anObject'] - ifFalse: [ - 1 to: aNumber do: [:argumentNumber | - stream - nextPutAll: 'with:'; space; - nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]]. - stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol]. - node := self class compilerClass new - compile: source - in: self class - notifying: nil - ifFail: []. - ^node generate.! Item was removed: - ----- Method: TraitTransformation>>theNonMetaClass (in category 'accessing parallel hierarchy') ----- - theNonMetaClass - ^ self subject theNonMetaClass ! Item was removed: - ----- Method: TraitMethodDescription>>effectiveMethodCategoryCurrent:new: (in category 'accessing') ----- - effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil - | result size isCurrent isConflict | - size := self size. - size = 0 ifTrue: [^ nil]. - result := self locatedMethods anyOne category. - size = 1 ifTrue: [^ result]. - - isCurrent := currentCategoryOrNil isNil. - isConflict := false. - self locatedMethods do: [:each | | cat | - cat := each category. - isCurrent := isCurrent or: [cat == currentCategoryOrNil]. - isConflict := isConflict or: [cat ~~ result]]. - isConflict ifFalse: [^ result]. - (isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil]. - ^ ClassOrganizer ambiguous.! Item was removed: - ----- Method: TraitMethodDescription>>isBinarySelector (in category 'testing') ----- - isBinarySelector - ^self locatedMethods anyOne - isBinarySelector! Item was removed: - ----- Method: TraitMethodDescription>>requiredMethodForArguments:ifAbsentPut: (in category 'private') ----- - requiredMethodForArguments: aNumber ifAbsentPut: aBlock - "ConflictMethods is an array that caches the generated conflict - methods. At position 1: binary method; 2: unary method; - n+2: keywordmethod with n arguments." - - ^(RequiredMethods at: aNumber) - ifNil: [ConflictMethods at: aNumber put: aBlock value]! Item was removed: - ----- Method: TraitMethodDescription class>>selector: (in category 'instance creation') ----- - selector: aSymbol - ^self new - selector: aSymbol - yourself! Item was removed: - ----- Method: TraitMethodDescription>>selector (in category 'accessing') ----- - selector - ^selector! Item was removed: - ----- Method: TraitComposition>>addCompositionOnLeft: (in category 'private') ----- - addCompositionOnLeft: aTraitComposition - self transformations do: [ : each | aTraitComposition add: each ]. - ^ aTraitComposition! Item was removed: - ----- Method: TraitAlias>>collectMethodsFor:into: (in category 'enquiries') ----- - collectMethodsFor: aSelector into: methodDescription - | originalSelector association | - self subject - collectMethodsFor: aSelector - into: methodDescription. - association := self aliasNamed: aSelector ifAbsent: [nil]. - association notNil ifTrue: [ - originalSelector := association value. - self subject - collectMethodsFor: originalSelector - into: methodDescription]! Item was removed: - ----- Method: TraitAlias>>copy (in category 'copying') ----- - copy - ^super copy - aliases: self aliases copy; - yourself! Item was removed: - ----- Method: TraitComposition>>remove: (in category 'accessing') ----- - remove: aTransformation - self transformations - remove: aTransformation! Item was removed: - ----- Method: TraitComposition>>notEmpty (in category 'testing') ----- - notEmpty - ^self isEmpty not! Item was removed: - ----- Method: TraitExclusion>>allSelectors (in category 'enquiries') ----- - allSelectors - | selectors | - selectors := self subject allSelectors. - self exclusions do: [:each | - selectors remove: each ifAbsent: []]. - ^selectors! Item was removed: - ----- Method: TraitAlias>>removeAlias: (in category 'composition') ----- - removeAlias: aSymbol - self aliases: (self aliases - reject: [:each | each key = aSymbol])! Item was removed: - ----- Method: TraitComposition>>copyWithoutAlias:of: (in category 'copying') ----- - copyWithoutAlias: aSymbol of: aTrait - | composition transformation | - composition := self copyTraitExpression. - transformation := (composition transformationOfTrait: aTrait). - ^composition - remove: transformation; - add: (transformation removeAlias: aSymbol); - normalizeTransformations; - yourself! Item was removed: - ----- Method: TraitAlias>>aliasNamed:ifAbsent: (in category 'enumeration') ----- - aliasNamed: aSymbol ifAbsent: aBlock - ^self aliases - detect: [:association | association key = aSymbol] - ifNone: aBlock! Item was removed: - ----- Method: TraitTransformation>>removeAlias: (in category 'composition') ----- - removeAlias: aSymbol - self subject removeAlias: aSymbol! Item was removed: - ----- Method: TraitComposition>>copyWithExclusionOf:to: (in category 'copying') ----- - copyWithExclusionOf: aSymbol to: aTrait - | composition transformation | - composition := self copyTraitExpression. - transformation := (composition transformationOfTrait: aTrait). - ^composition - remove: transformation; - add: (transformation addExclusionOf: aSymbol); - yourself! Item was removed: - ----- Method: TraitMethodDescription>>isRequired (in category 'testing') ----- - isRequired - self isEmpty ifTrue: [^ false]. - ^ self locatedMethods allSatisfy: [:each | each method isRequired]! Item was removed: - ----- Method: TraitComposition>>transformationOfTrait: (in category 'accessing') ----- - transformationOfTrait: aTrait - "Return the transformation which holds aTrait - or nil if this composition doesn't include aTrait." - - ^self transformations - detect: [:each | each trait = aTrait] - ifNone: [nil]! Item was removed: - ----- Method: TraitMethodDescription>>effectiveMethodCategory (in category 'accessing') ----- - effectiveMethodCategory - ^ self effectiveMethodCategoryCurrent: nil new: nil! Item was removed: - ----- Method: TraitMethodDescription class>>maxArguments (in category 'private') ----- - maxArguments - ^30! Item was removed: - ----- Method: TraitComposition>>normalizeTransformations (in category 'composition') ----- - normalizeTransformations - self transformations: ( - self transformations collect: [:each | - each normalized])! Item was removed: - ----- Method: TraitTransformation>>isMeta (in category 'accessing parallel hierarchy') ----- - isMeta - ^self subject isMeta! Item was removed: - ----- Method: TraitAlias>>isEmpty (in category 'testing') ----- - isEmpty - ^self aliases isEmpty! Item was removed: - ----- Method: TraitComposition>>changedSelectorsComparedTo: (in category 'enquiries') ----- - changedSelectorsComparedTo: oldComposition - | changedSelectors traits | - changedSelectors := IdentitySet new. - traits := self traits asIdentitySet addAll: oldComposition traits asIdentitySet; yourself. - traits do: [:each | | oldTransformation newTransformation | - newTransformation := self transformationOfTrait: each. - oldTransformation := oldComposition transformationOfTrait: each. - (newTransformation isNil or: [oldTransformation isNil]) - ifTrue: [ - changedSelectors addAll: each selectors] - ifFalse: [ - changedSelectors addAll: - (newTransformation changedSelectorsComparedTo: oldTransformation)]]. - ^changedSelectors! Item was removed: - ----- Method: TraitMethodDescription class>>initialize (in category 'class initialization') ----- - initialize - " self initialize " - ConflictMethods := Array new: self maxArguments + 2. - RequiredMethods := Array new: self maxArguments + 2.! Item was removed: - ----- Method: TraitMethodDescription>>methodsDo: (in category 'enumeration') ----- - methodsDo: aBlock - self locatedMethods do: [:each | - aBlock value: each method]! Item was removed: - ----- Method: TraitMethodDescription>>getArgumentNames (in category 'private') ----- - getArgumentNames - | argumentNamesCollection names defaultName | - defaultName := 'arg'. - argumentNamesCollection := self locatedMethods - collect: [:each | each argumentNames ]. - names := Array new: argumentNamesCollection anyOne size. - argumentNamesCollection do: [:collection | - 1 to: names size do: [:index | - (names at: index) isNil - ifTrue: [names at: index put: (collection at: index)] - ifFalse: [(names at: index) ~= (collection at: index) - ifTrue: [names at: index put: defaultName, index asString]]]]. - ^names - ! Item was removed: - ----- Method: TraitComposition>>addOnTheLeft: (in category 'composition') ----- - addOnTheLeft: aTrait - self errorIfNotAddable: aTrait. - self transformations addFirst: aTrait! Item was removed: - ----- Method: TraitMethodDescription>>conflictMethodForArguments:ifAbsentPut: (in category 'private') ----- - conflictMethodForArguments: aNumber ifAbsentPut: aBlock - "ConflictMethods is an array that caches the generated conflict - methods. At position 1: binary method; 2: unary method; - n+2: keywordmethod with n arguments." - - ^(ConflictMethods at: aNumber) - ifNil: [ConflictMethods at: aNumber put: aBlock value]! Item was removed: - ----- Method: TraitExclusion>>methodReferencesInCategory: (in category 'accessing') ----- - methodReferencesInCategory: aCategoryName - ^(self organization listAtCategoryNamed: aCategoryName) - collect: [:ea | MethodReference new - setClassSymbol: self theNonMetaClass name - classIsMeta: self isMeta - methodSymbol: ea - stringVersion: ''] - ! Item was removed: - ----- Method: TraitMethodDescription>>isConflict (in category 'testing') ----- - isConflict - | count | - count := 0. - self methodsDo: [:each | - each isProvided ifTrue: [ - count := count + 1. - count > 1 ifTrue: [^true]]]. - ^false! Item was removed: - ----- Method: TraitAlias>>aliasesForSelector: (in category 'enquiries') ----- - aliasesForSelector: aSymbol - | selectors | - selectors := self aliases - select: [:association | association value = aSymbol] - thenCollect: [:association | association key]. - ^(super aliasesForSelector: aSymbol) - addAll: selectors; - yourself - ! Item was removed: - ----- Method: TraitTransformation>>normalized (in category 'accessing') ----- - normalized - ^self isEmpty - ifFalse: [ - self subject: self subject normalized. - self] - ifTrue: [self subject normalized] - - ! Item was removed: - ----- Method: TraitMethodDescription>>selector: (in category 'accessing') ----- - selector: aSymbol - selector := aSymbol! Item was removed: - ----- Method: TraitTransformation>>aliasesForSelector: (in category 'enquiries') ----- - aliasesForSelector: aSymbol - "Return a collection of alias selectors that are defined in this transformation." - - ^self subject aliasesForSelector: aSymbol! Item was removed: - Object subclass: #TraitMethodDescription - instanceVariableNames: 'selector locatedMethods' - classVariableNames: 'ConflictMethods RequiredMethods' - poolDictionaries: '' - category: 'Traits-Composition'! - - !TraitMethodDescription commentStamp: '<historical>' prior: 0! - Used by TraitComposition to encapsulates a collection of methods for one particular selector when querying for changes. According to the number and kind of those methods a provided method exists, there is a conflict or there are no provided nor conflicting methods at all. I provide the interface to query for those situations, e.g., effectiveMethod returns the provided method or the conflict marker method. - ! Item was removed: - ----- Method: TraitTransformation>>collectMethodsFor:into: (in category 'enquiries') ----- - collectMethodsFor: aSelector into: methodDescription - "Collect instances of LocatedMethod into methodDescription - for each method that has the selector aSelector and is not excluded - or for which aSelector is an alias." - - self subclassResponsibility! Item was removed: - ----- Method: TraitTransformation>>copy (in category 'copying') ----- - copy - self error: 'should not be called'. - ^super copy - subject: self subject copy; - yourself! Item was removed: - ----- Method: TraitTransformation>>sourceCodeTemplate (in category 'browser support') ----- - sourceCodeTemplate - ^ self subject sourceCodeTemplate! Item was removed: - ----- Method: TraitMethodDescription>>conflictMethod (in category 'accessing') ----- - conflictMethod - | templateMethod argumentNames binary numberOfArguments | - self isConflict ifFalse: [^nil]. - argumentNames := self getArgumentNames. - binary := self isBinarySelector. - numberOfArguments := binary - ifTrue: [1] - ifFalse: [argumentNames size + 2]. - templateMethod := self conflictMethodForArguments: numberOfArguments ifAbsentPut: [ - self - generateTemplateMethodWithMarker: CompiledMethod conflictMarker - forArgs: argumentNames size - binary: binary]. - ^templateMethod copyWithTempNames: argumentNames - - - ! Item was removed: - ----- Method: TraitComposition>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - transformations := OrderedCollection new! Item was removed: - ----- Method: TraitComposition>>add: (in category 'accessing') ----- - add: aTraitTransformation - self errorIfNotAddable: aTraitTransformation. - self transformations addLast: aTraitTransformation! Item was removed: - Error subclass: #TraitException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Traits-Kernel'! - - !TraitException commentStamp: '<historical>' prior: 0! - General exception used for example to signal invalid trait compositions! Item was removed: - ----- Method: TraitMethodDescription>>effectiveMethod (in category 'accessing') ----- - effectiveMethod - "Return the effective compiled method of this method description." - - | locatedMethod method | - method := self providedMethod. - method isNil ifFalse: [^ method]. - method := self conflictMethod. - method isNil ifFalse: [^ method]. - ^ self requiredMethod.! Item was removed: - ----- Method: TraitComposition class>>with:with: (in category 'instance creation') ----- - with: aTraitTransformation with: anotherTraitTransformation - ^self new - add: aTraitTransformation; - add: anotherTraitTransformation; - yourself! Item was removed: - ----- Method: TraitMethodDescription>>addLocatedMethod: (in category 'accessing') ----- - addLocatedMethod: aLocatedMethod - locatedMethods add: aLocatedMethod! Item was removed: - ----- Method: TraitTransformation>>printOn: (in category 'printing') ----- - printOn: aStream - aStream print: self subject! Item was removed: - ----- Method: NanoTrait class>>unloadNanoTraits (in category 'installing') ----- - unloadNanoTraits - "Unload NanoTraits" - ClassDescription traitImpl == self - ifTrue:[ClassDescription traitImpl: nil]. - - CompiledMethod allInstancesDo:[:cm| - "Clean out NanoTraitState for all methods; this makes all methods local" - (cm properties isKindOf: NanoTraitMethodState) ifTrue:[ - cm penultimateLiteral: (AdditionalMethodState newFrom: cm properties). - ]. - ]. - - self allTraitsDo:[:trait| - "Clean out the existing users for this trait" - trait users do:[:user| user uses: {}]. - ]. - - "We need a stub updateTraits method during unload" - [Behavior halt compileSilently: 'updateTraits' classified: nil. - "Finally, unload NanoTraits" - (MCPackage named: 'NanoTraits') unload. - ] ensure:[Behavior removeSelectorSilently: #updateTraits]. - - Smalltalk allClassesAndTraitsDo:[:aClass| - "Clean out existing NanoTraitCompositions" - (aClass traitComposition class isObsolete) - ifTrue:[aClass traitComposition: #()]. - (aClass classSide traitComposition class isObsolete) - ifTrue:[aClass classSide traitComposition: #()]. - ]. - - Smalltalk at: #Trait ifPresent:[:aClass| - aClass isObsolete ifTrue:[Smalltalk at: #Trait put: nil]. - ]. - - Compiler recompileAll.! Item was removed: - ----- Method: TraitTransformation>>changedSelectorsComparedTo: (in category 'enquiries') ----- - changedSelectorsComparedTo: aTraitTransformation - | selectors otherSelectors changedSelectors aliases otherAliases | - selectors := self allSelectors asIdentitySet. - otherSelectors := aTraitTransformation allSelectors asIdentitySet. - changedSelectors := IdentitySet withAll: ( - (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). - aliases := self allAliasesDict. - otherAliases := aTraitTransformation allAliasesDict. - aliases keysAndValuesDo: [:key :value | - (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. - otherAliases keysAndValuesDo: [:key :value | - (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. - ^ changedSelectors.! Item was removed: - ----- Method: TraitTransformation>>isEmpty (in category 'testing') ----- - isEmpty - self subclassResponsibility! Item was removed: - ----- Method: TraitTransformation>>selectors (in category 'enquiries') ----- - selectors - ^self allSelectors! Item was removed: - ----- Method: TraitMethodDescription>>isAliasSelector (in category 'testing') ----- - isAliasSelector - "Return true if the selector is an alias (if it is different - from the original selector) or already an aliased method - in the original location (recursively search the compositions). - Return false, if not or if we have a conflict." - - | locatedMethod | - ^self size = 1 and: [ - locatedMethod := self locatedMethods anyOne. - (locatedMethod selector ~= self selector) or: [ - locatedMethod location isAliasSelector: self selector]]! Item was removed: - ----- Method: TraitTransformation>>addExclusionOf: (in category 'composition') ----- - addExclusionOf: aSymbol - ^self - {aSymbol}! Item was removed: - ----- Method: TraitMethodDescription>>requiredMethod (in category 'accessing') ----- - requiredMethod - | templateMethod argumentNames numberOfArguments binary | - self isRequired ifFalse: [^nil]. - self size = 1 ifTrue: [^self locatedMethods anyOne method]. - - argumentNames := self getArgumentNames. - binary := self isBinarySelector. - numberOfArguments := binary - ifTrue: [1] - ifFalse: [argumentNames size + 2]. - templateMethod := self requiredMethodForArguments: numberOfArguments ifAbsentPut: [ - self - generateTemplateMethodWithMarker: CompiledMethod implicitRequirementMarker - forArgs: argumentNames size - binary: binary]. - ^templateMethod copyWithTempNames: argumentNames - - - ! Item was removed: - ----- Method: TraitMethodDescription>>locatedMethods (in category 'accessing') ----- - locatedMethods - ^locatedMethods! Item was removed: - ----- Method: TraitMethodDescription>>providedLocatedMethod (in category 'accessing') ----- - providedLocatedMethod - | locatedMethod | - locatedMethod := nil. - self locatedMethods do: [:each | - each method isProvided ifTrue: [ - locatedMethod isNil ifFalse: [^nil]. - locatedMethod := each]]. - ^locatedMethod! Item was removed: - ----- Method: TraitComposition class>>with: (in category 'instance creation') ----- - with: aTraitTransformation - ^self new - add: aTraitTransformation; - yourself! Item was removed: - ----- Method: TraitExclusion>>collectMethodsFor:into: (in category 'enquiries') ----- - collectMethodsFor: aSelector into: methodDescription - (self exclusions includes: aSelector) ifFalse: [ - self subject - collectMethodsFor: aSelector - into: methodDescription]! Item was removed: - ----- Method: TraitMethodDescription>>providedMethod (in category 'accessing') ----- - providedMethod - ^self providedLocatedMethod ifNotNil: [:locatedMethod | locatedMethod method]! Item was removed: - ----- Method: TraitExclusion>>copy (in category 'copying') ----- - copy - ^super copy - exclusions: self exclusions copy; - yourself! Item was removed: - ----- Method: TraitMethodDescription>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - locatedMethods := Set new! Item was removed: - ----- Method: TraitTransformation>>traitTransformations (in category 'enquiries') ----- - traitTransformations - ^ { subject }! Item was removed: - ----- Method: TraitComposition>>transformations: (in category 'private') ----- - transformations: aCollection - transformations := aCollection!

1 0

The Trunk: Kernel-ar.352.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ar.352.mcz ==================== Summary ==================== Name: Kernel-ar.352 Author: ar Time: 29 December 2009, 5:41:30 am UUID: 090c5c02-8b1a-d34f-a88d-1c203c1ddcfa Ancestors: Kernel-ar.351 Shipping NanoTraits part 4: Here comes the big clean up. Let's see if it's loadable :-) =============== Diff against Kernel-ar.351 =============== Item was changed: ----- Method: Class>>category: (in category 'organization') ----- category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization." | oldCategory | + oldCategory := category. - oldCategory := self basicCategory. aString isString ifTrue: [ + category := aString asSymbol. + SystemOrganization classify: self name under: category ] - self basicCategory: aString asSymbol. - SystemOrganization classify: self name under: self basicCategory ] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance + class: self recategorizedFrom: oldCategory to: category! - class: self recategorizedFrom: oldCategory to: self basicCategory! Item was changed: ----- Method: Behavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') ----- addSelectorSilently: selector withMethod: compiledMethod + self basicAddSelector: selector withMethod: compiledMethod.! - self methodDictAddSelectorSilently: selector withMethod: compiledMethod. - self registerLocalSelector: selector! Item was changed: ----- Method: Class>>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)" + category ifNotNil: [ :symbol | - | result | - self basicCategory ifNotNil: [ :symbol | ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^symbol ] ]. + category := SystemOrganization categoryOfElement: self name. + ^category! - self basicCategory: (result := SystemOrganization categoryOfElement: self name). - ^result! Item was changed: ----- Method: Behavior>>localSelectors (in category 'adding/removing methods') ----- localSelectors + "Return a set of selectors defined locally." + ^ self selectors + ! - "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 changed: ----- Method: Behavior>>includesLocalSelector: (in category 'testing method dictionary') ----- includesLocalSelector: aSymbol + ^self includesSelector: aSymbol! - ^self basicLocalSelectors isNil - ifTrue: [self includesSelector: aSymbol] - ifFalse: [self localSelectors includes: aSymbol]! Item was changed: ----- Method: Metaclass>>uses:instanceVariableNames: (in category 'initialize-release') ----- uses: aTraitCompositionOrArray instanceVariableNames: instVarString | newComposition newMetaClass copyOfOldMetaClass | copyOfOldMetaClass := self copy. newMetaClass := self instanceVariableNames: instVarString. newComposition := aTraitCompositionOrArray asTraitComposition. - newMetaClass assertConsistantCompositionsForNew: newComposition. newMetaClass setTraitComposition: newComposition. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! Item was removed: - ----- Method: Behavior>>clearSendCaches (in category 'send caches') ----- - clearSendCaches - LocalSends current clearOut: self! Item was removed: - ----- Method: Behavior>>traitComposition (in category 'traits') ----- - traitComposition - self subclassResponsibility! Item was removed: - ----- Method: Behavior>>basicLocalSelectors: (in category 'accessing method dictionary') ----- - basicLocalSelectors: aSetOrNil - self subclassResponsibility ! Item was removed: - ----- Method: Class>>basicLocalSelectors (in category 'accessing') ----- - 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: Behavior>>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: Class>>hasTraitComposition (in category 'accessing') ----- - hasTraitComposition - ^traitComposition notNil and:[traitComposition isEmpty not]! Item was removed: - ----- Method: Behavior>>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: - ----- Method: Behavior>>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: Behavior>>deregisterLocalSelector: (in category 'accessing method dictionary') ----- - deregisterLocalSelector: aSymbol - self basicLocalSelectors notNil ifTrue: [ - self basicLocalSelectors remove: aSymbol ifAbsent: []]! Item was removed: - ----- Method: Behavior>>registerLocalSelector: (in category 'accessing method dictionary') ----- - registerLocalSelector: aSymbol - self basicLocalSelectors notNil ifTrue: [ - self basicLocalSelectors add: aSymbol]! Item was removed: - ----- Method: Metaclass>>hasTraitComposition (in category 'accessing') ----- - hasTraitComposition - ^traitComposition notNil and:[traitComposition isEmpty not]! Item was removed: - ----- Method: Behavior>>basicAddTraitSelector:withMethod: (in category 'traits') ----- - basicAddTraitSelector: 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: Behavior>>removeFromComposition: (in category 'traits') ----- - removeFromComposition: aTrait - self setTraitComposition: (self traitComposition copy - removeFromComposition: aTrait)! Item was removed: - ----- Method: Behavior>>removeAlias:of: (in category 'traits') ----- - removeAlias: aSymbol of: aTrait - self setTraitComposition: ( - self traitComposition copyWithoutAlias: aSymbol of: aTrait)! Item was removed: - ----- Method: Metaclass>>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: - ----- Method: Behavior>>requirements (in category 'send caches') ----- - requirements - ^ self requiredSelectorsCache - ifNil: [#()] - ifNotNil: [:rsc | rsc requirements]! Item was removed: - ----- Method: Class>>basicCategory (in category 'accessing') ----- - basicCategory - ^category! Item was removed: - ----- Method: Behavior>>traitComposition: (in category 'traits') ----- - traitComposition: aTraitComposition - self subclassResponsibility ! Item was removed: - ----- Method: Behavior>>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: Metaclass>>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: Metaclass>>basicLocalSelectors: (in category 'accessing') ----- - basicLocalSelectors: aSetOrNil - localSelectors := aSetOrNil! Item was removed: - ----- Method: Behavior>>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: Behavior>>notifyUsersOfChangedSelector: (in category 'traits') ----- - notifyUsersOfChangedSelector: aSelector - self notifyUsersOfChangedSelectors: (Array with: aSelector)! Item was removed: - ----- Method: Behavior>>parseScope (in category 'newcompiler') ----- - parseScope - - ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! Item was removed: - ----- Method: Behavior>>hasRequiredSelectors (in category 'send caches') ----- - hasRequiredSelectors - ^ self requiredSelectors notEmpty! Item was removed: - ----- Method: Behavior>>methodDictAddSelectorSilently:withMethod: (in category 'adding/removing methods') ----- - methodDictAddSelectorSilently: selector withMethod: compiledMethod - self basicAddSelector: selector withMethod: compiledMethod! Item was removed: - ----- Method: Metaclass>>basicLocalSelectors (in category 'accessing') ----- - 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: Behavior>>purgeLocalSelectors (in category 'traits') ----- - purgeLocalSelectors - self basicLocalSelectors: nil! Item was removed: - ----- Method: Behavior>>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: Behavior>>addTraitSelector:withMethod: (in category 'traits') ----- - addTraitSelector: aSymbol withMethod: aCompiledMethod - self basicAddTraitSelector: aSymbol withMethod: aCompiledMethod. - aCompiledMethod sendsToSuper ifTrue: [ - self recompile: aSymbol]! Item was removed: - ----- Method: Behavior>>superRequirements (in category 'send caches') ----- - superRequirements - ^ self requiredSelectorsCache superRequirements! Item was removed: - ----- Method: Behavior>>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: Behavior>>isProvidedSelector: (in category 'testing method dictionary') ----- - isProvidedSelector: selector - ^ ProvidedSelectors current isSelector: selector providedIn: self - ! Item was removed: - ----- Method: Behavior>>notifyUsersOfChangedSelectors: (in category 'traits') ----- - notifyUsersOfChangedSelectors: aCollection! Item was removed: - ----- Method: Behavior>>removeTraitSelector: (in category 'traits') ----- - removeTraitSelector: aSymbol - self assert: [(self includesLocalSelector: aSymbol) not]. - self basicRemoveSelector: aSymbol! Item was removed: - ----- Method: Behavior>>canPerform: (in category 'testing method dictionary') ----- - canPerform: selector - "Answer whether the receiver can safely perform to the message whose selector - is the argument: it is not an abstract or cancelled method" - - ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! Item was removed: - ----- Method: Class>>basicCategory: (in category 'accessing') ----- - basicCategory: aSymbol - category := aSymbol! Item was removed: - ----- Method: Behavior>>addExclusionOf:to: (in category 'traits') ----- - addExclusionOf: aSymbol to: aTrait - self setTraitComposition: ( - self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! Item was removed: - ----- Method: Behavior>>basicLocalSelectors (in category 'accessing method dictionary') ----- - basicLocalSelectors - "Direct accessor for the instance variable localSelectors. - Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and - Metaclass declare the needed ivar and override this method as an accessor. - By returning nil instead of declaring this method as a subclass responsibility, - Behavior can be instantiated for creating anonymous classes." - - ^nil! Item was removed: - ----- Method: Behavior>>traitTransformations (in category 'traits') ----- - traitTransformations - ^ self traitComposition transformations ! Item was removed: - ----- Method: Behavior>>hasTraitComposition (in category 'traits') ----- - hasTraitComposition - self subclassResponsibility ! Item was removed: - ----- Method: Behavior>>sendCaches: (in category 'send caches') ----- - sendCaches: aSendCaches - ^ self explicitRequirement! Item was removed: - ----- Method: Behavior>>isDisabledSelector: (in category 'testing method dictionary') ----- - isDisabledSelector: selector - ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! Item was removed: - ----- Method: Behavior>>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: Class>>basicLocalSelectors: (in category 'accessing') ----- - basicLocalSelectors: aSetOrNil - localSelectors := aSetOrNil! Item was removed: - ----- Method: Behavior>>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: Behavior>>addToComposition: (in category 'traits') ----- - addToComposition: aTrait - self setTraitComposition: (self traitComposition copyTraitExpression - add: aTrait; - yourself)! Item was removed: - ----- Method: Behavior>>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: Behavior>>traitCompositionString (in category 'traits') ----- - traitCompositionString - ^self hasTraitComposition - ifTrue: [self traitComposition asString] - ifFalse: ['{}']! Item was removed: - ----- Method: Behavior>>traitCompositionIncludes: (in category 'traits') ----- - traitCompositionIncludes: aTrait - ^self == aTrait or: - [self hasTraitComposition and: - [self traitComposition allTraits includes: aTrait]]! Item was removed: - ----- Method: Behavior>>setTraitCompositionFrom: (in category 'traits') ----- - setTraitCompositionFrom: aTraitExpression - ^ self setTraitComposition: aTraitExpression asTraitComposition!

1 0

The Trunk: Traits-ar.255.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Traits to project The Trunk: http://source.squeak.org/trunk/Traits-ar.255.mcz ==================== Summary ==================== Name: Traits-ar.255 Author: ar Time: 29 December 2009, 5:09:05 am UUID: ceb2a719-a3b0-da48-b6b6-3280be713b59 Ancestors: Traits-ar.254 Shipping NanoTraits part 3: A hand ful of small changes that pave the way for the (major) follow-on cleanup. =============== Diff against Traits-ar.254 =============== Item was changed: ----- 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. + ]. + ! - self isAbstract not ifTrue: - [self current: self new]!

1 0

The Trunk: Kernel-ar.351.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ar.351.mcz ==================== Summary ==================== Name: Kernel-ar.351 Author: ar Time: 29 December 2009, 4:53:50 am UUID: adffc800-4eb7-2f43-a55d-f827d0627605 Ancestors: Kernel-ar.350 Shipping NanoTraits part 3: A hand ful of small changes that pave the way for the (major) follow-on cleanup. =============== Diff against Kernel-ar.350 =============== Item was changed: ----- Method: Behavior>>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." + ^self basicRemoveSelector: aSelector - 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 | - - "-- support for alternative trait implementation --" - (self traitComposition isKindOf: TraitComposition) - ifFalse:[^self basicRemoveSelector: aSelector]. - - changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) - and: [self hasTraitComposition] - and: [self traitComposition includesMethod: aSelector]. - - changeFromLocalToTraitMethod - ifFalse: [self basicRemoveSelector: aSelector] - ifTrue: [self ensureLocalSelectors]. - self deregisterLocalSelector: aSelector. - self noteChangedSelectors: (Array with: aSelector) - ! Item was changed: ----- Method: ClassDescription>>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. + SystemChangeNotifier uniqueInstance doSilently: [ + self organization removeElement: selector]. - "-- support for alternative trait implementation --" - (self traitComposition isKindOf: TraitComposition) ifFalse:[ - SystemChangeNotifier uniqueInstance doSilently: [ - self organization removeElement: selector]. - ]. super removeSelector: selector. + - (self traitComposition isKindOf: TraitComposition) ifTrue:[ - SystemChangeNotifier uniqueInstance doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. - ]. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! Item was changed: ----- Method: Behavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') ----- addSelector: selector withMethod: compiledMethod notifying: requestor + ^ self basicAddSelector: selector withMethod: compiledMethod! - ^ self addSelectorSilently: selector withMethod: compiledMethod! Item was removed: - ----- Method: Behavior>>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: ClassDescription>>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: ClassDescription>>applyChangesOfNewTraitCompositionReplacing: (in category 'organization updating') ----- - applyChangesOfNewTraitCompositionReplacing: oldComposition - | changedSelectors | - changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. - self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. - ^ changedSelectors.! Item was removed: - ----- Method: Class>>applyChangesOfNewTraitCompositionReplacing: (in category 'traits') ----- - applyChangesOfNewTraitCompositionReplacing: oldComposition - "See Trait>>applyChangesOfNewTraitCompositionReplacing:" - | changedSelectors | - changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. - self classSide - noteNewBaseTraitCompositionApplied: self traitComposition. - ^ changedSelectors! Item was removed: - ----- Method: ClassDescription>>updateOrganizationSelector:oldCategory:newCategory: (in category 'organization updating') ----- - updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil - | currentCategory effectiveCategory sel changedCategories composition | - changedCategories := IdentitySet new. - composition := self hasTraitComposition - ifTrue: [self traitComposition] - ifFalse: [TraitComposition new]. - - "-- support for alternative trait implementation --" - (composition isKindOf: TraitComposition) ifFalse:[^self]. - - (composition methodDescriptionsForSelector: aSymbol) do: [:each | - sel := each selector. - (self includesLocalSelector: sel) ifFalse: [ - currentCategory := self organization categoryOfElement: sel. - effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. - effectiveCategory isNil ifTrue: [ - currentCategory ifNotNil: [changedCategories add: currentCategory]. - self organization removeElement: sel. - ] ifFalse: [ - ((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [ - currentCategory ifNotNil: [changedCategories add: currentCategory]. - self organization - classify: sel - under: effectiveCategory - suppressIfDefault: false]]]]. - ^ changedCategories! Item was removed: - ----- Method: ClassDescription>>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]]!

1 0

The Trunk: Kernel-ar.350.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ar.350.mcz ==================== Summary ==================== Name: Kernel-ar.350 Author: ar Time: 29 December 2009, 4:35:59 am UUID: d0cb0117-72d6-384e-8065-adcb9229b9ea Ancestors: Kernel-ar.349 Shipping NanoTraits part 2: Commit Kernel package back after NanoTraits install. =============== Diff against Kernel-ar.349 =============== Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>clearSendCaches (in category 'send caches') ----- + clearSendCaches + LocalSends current clearOut: self! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>removeSelectorSilently: (in category 'adding/removing methods') ----- + removeSelectorSilently: selector + "Remove selector without sending system change notifications" + + ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>compileAll (in category 'compiling') ----- + compileAll + ^ self compileAllFrom: self! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>isInstanceSide (in category 'accessing parallel hierarchy') ----- + isInstanceSide + ^self isClassSide not! Item was added: + ----- Method: ClassDescription>>storeOn: (in category 'printing') ----- + storeOn: aStream + "Classes and Metaclasses have global names." + + aStream nextPutAll: self name! Item was added: + ----- Method: Behavior>>deregisterLocalSelector: (in category 'accessing method dictionary') ----- + deregisterLocalSelector: aSymbol + self basicLocalSelectors notNil ifTrue: [ + self basicLocalSelectors remove: aSymbol ifAbsent: []]! Item was added: + ----- Method: Behavior>>registerLocalSelector: (in category 'accessing method dictionary') ----- + registerLocalSelector: aSymbol + self basicLocalSelectors notNil ifTrue: [ + self basicLocalSelectors add: aSymbol]! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>basicAddTraitSelector:withMethod: (in category 'traits') ----- + basicAddTraitSelector: 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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>printCategoryChunk:withStamp:on: (in category 'fileIn/Out') ----- + printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream + ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp + priorMethod: nil! Item was added: + ----- Method: Behavior>>binding (in category 'compiling') ----- + binding + ^ nil -> self! Item was added: + ----- Method: Behavior>>removeFromComposition: (in category 'traits') ----- + removeFromComposition: aTrait + self setTraitComposition: (self traitComposition copy + removeFromComposition: aTrait)! Item was added: + ----- Method: Class>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>compress (in category 'accessing method dictionary') ----- + compress + "Compact the method dictionary of the receiver." + + self methodDict rehash! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') ----- + addSelectorSilently: selector withMethod: compiledMethod + self methodDictAddSelectorSilently: selector withMethod: compiledMethod. + self registerLocalSelector: selector! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>removeAlias:of: (in category 'traits') ----- + removeAlias: aSymbol of: aTrait + self setTraitComposition: ( + self traitComposition copyWithoutAlias: aSymbol of: aTrait)! Item was added: + ----- Method: ClassDescription>>printOnStream: (in category 'printing') ----- + printOnStream: aStream + aStream print: self name! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>methodsFor:stamp: (in category 'fileIn/Out') ----- + methodsFor: categoryName stamp: changeStamp + ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! Item was added: + ----- Method: ClassDescription>>fileOutCategory: (in category 'fileIn/Out') ----- + fileOutCategory: catName + ^ self fileOutCategory: catName asHtml: false! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + Object subclass: #Behavior + instanceVariableNames: 'superclass methodDict format' + classVariableNames: 'ObsoleteSubclasses' + poolDictionaries: '' + category: 'Kernel-Classes'! + + !Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0! + My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Metaclass>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>requirements (in category 'send caches') ----- + requirements + ^ self requiredSelectorsCache + ifNil: [#()] + ifNotNil: [:rsc | rsc requirements]! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>hasMethods (in category 'testing method dictionary') ----- + hasMethods + "Answer whether the receiver has any methods in its method dictionary." + + ^ self methodDict size > 0! Item was added: + ----- Method: Metaclass>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>notifyUsersOfChangedSelector: (in category 'traits') ----- + notifyUsersOfChangedSelector: aSelector + self notifyUsersOfChangedSelectors: (Array with: aSelector)! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>printOn: (in category 'printing') ----- + printOn: aStream + aStream nextPutAll: self name! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>errorCategoryName (in category 'private') ----- + errorCategoryName + self error: 'Category name must be a String'! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ClassDescription subclass: #Class + instanceVariableNames: 'subclasses name classPool sharedPools environment category traitComposition localSelectors' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Classes'! + + !Class commentStamp: '<historical>' prior: 0! + I add a number of facilities to those in ClassDescription: + A set of all my subclasses (defined in ClassDescription, but only used here and below) + A name by which I can be found in a SystemDictionary + A classPool for class variables shared between this class and its metaclass + A list of sharedPools which probably should be supplanted by some better mechanism. + + My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. + + The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. ! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>parseScope (in category 'newcompiler') ----- + parseScope + + ^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]! Item was added: + ----- Method: ClassDescription>>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 added: Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>hasRequiredSelectors (in category 'send caches') ----- + hasRequiredSelectors + ^ self requiredSelectors notEmpty! Item was added: + Behavior subclass: #ClassDescription + instanceVariableNames: 'instanceVariables organization' + classVariableNames: 'TraitImpl' + poolDictionaries: '' + category: 'Kernel-Classes'! + + !ClassDescription commentStamp: '<historical>' prior: 0! + I add a number of facilities to basic Behaviors: + Named instance variables + Category organization for methods + The notion of a name of this class (implemented as subclass responsibility) + The maintenance of a ChangeSet, and logging changes on a file + Most of the mechanism for fileOut. + + I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass. + + The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).! Item was added: + ----- Method: Behavior>>methodDictAddSelectorSilently:withMethod: (in category 'adding/removing methods') ----- + methodDictAddSelectorSilently: selector withMethod: compiledMethod + self basicAddSelector: selector withMethod: compiledMethod! Item was added: + ----- Method: Behavior>>purgeLocalSelectors (in category 'traits') ----- + purgeLocalSelectors + self basicLocalSelectors: nil! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>methodDictionary: (in category 'accessing method dictionary') ----- + methodDictionary: aDictionary + self methodDict: aDictionary! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>superRequirements (in category 'send caches') ----- + superRequirements + ^ self requiredSelectorsCache superRequirements! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>isProvidedSelector: (in category 'testing method dictionary') ----- + isProvidedSelector: selector + ^ ProvidedSelectors current isSelector: selector providedIn: self + ! Item was added: + ----- Method: Behavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') ----- + addSelector: selector withMethod: compiledMethod notifying: requestor + ^ self addSelectorSilently: selector withMethod: compiledMethod! Item was added: + ----- Method: ClassDescription>>wantsRecompilationProgressReported (in category 'compiling') ----- + wantsRecompilationProgressReported + "Answer whether the receiver would like progress of its recompilation reported interactively to the user." + + ^ true! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Class>>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 added: + ----- Method: ClassDescription>>isMeta (in category 'accessing parallel hierarchy') ----- + isMeta + ^self isClassSide! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>environment (in category 'naming') ----- + environment + "Return the environment in which the receiver is visible" + ^Smalltalk! Item was added: + ----- Method: Behavior>>notifyUsersOfChangedSelectors: (in category 'traits') ----- + notifyUsersOfChangedSelectors: aCollection! Item was added: + ----- Method: Behavior>>evaluatorClass (in category 'compiling') ----- + evaluatorClass + "Answer an evaluator class appropriate for evaluating expressions in the + context of this class." + + ^Compiler! Item was added: + ----- Method: Behavior>>canZapMethodDictionary (in category 'testing') ----- + canZapMethodDictionary + "Return true if it is safe to zap the method dictionary on #obsolete" + ^true! Item was added: + ----- Method: Behavior>>includesLocalSelector: (in category 'testing method dictionary') ----- + includesLocalSelector: aSymbol + ^self basicLocalSelectors isNil + ifTrue: [self includesSelector: aSymbol] + ifFalse: [self localSelectors includes: aSymbol]! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>removeTraitSelector: (in category 'traits') ----- + removeTraitSelector: aSymbol + self assert: [(self includesLocalSelector: aSymbol) not]. + self basicRemoveSelector: aSymbol! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>decompilerClass (in category 'compiling') ----- + decompilerClass + "Answer a decompiler class appropriate for compiled methods of this class." + + ^ self compilerClass decompilerClass! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ClassDescription subclass: #Metaclass + instanceVariableNames: 'thisClass traitComposition localSelectors' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Classes'! + + !Metaclass commentStamp: '<historical>' prior: 0! + My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. + + [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, + Integer superclass == Number, and + Integer class superclass == Number class. + However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, + Object superclass == nil, and + Object class superclass == Class. + + [Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>prettyPrinterClass (in category 'printing') ----- + prettyPrinterClass + ^self compilerClass! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>parserClass (in category 'compiling') ----- + parserClass + "Answer a parser class to use for parsing method headers." + + ^self compilerClass parserClass! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>emptyMethodDictionary (in category 'initialization') ----- + emptyMethodDictionary + + ^ MethodDictionary new! Item was added: + ----- Method: ClassDescription>>applyChangesOfNewTraitCompositionReplacing: (in category 'organization updating') ----- + applyChangesOfNewTraitCompositionReplacing: oldComposition + | changedSelectors | + changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. + self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. + ^ changedSelectors.! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>comment: (in category 'accessing comment') ----- + comment: aStringOrText + "Set the receiver's comment to be the argument, aStringOrText." + + self instanceSide classComment: aStringOrText.! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>copyOfMethodDictionary (in category 'copying') ----- + copyOfMethodDictionary + "Return a copy of the receiver's method dictionary" + + ^ self methodDict copy! Item was added: + ----- Method: Behavior>>addExclusionOf:to: (in category 'traits') ----- + addExclusionOf: aSymbol to: aTrait + self setTraitComposition: ( + self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>fileOutOn: (in category 'fileIn/Out') ----- + fileOutOn: aFileStream + "File a description of the receiver on aFileStream." + + self fileOutOn: aFileStream + moveSource: false + toFile: 0! Item was added: + ----- Method: Behavior>>addSelector:withMethod: (in category 'adding/removing methods') ----- + addSelector: selector withMethod: compiledMethod + ^ self addSelector: selector withMethod: compiledMethod notifying: nil! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>traitTransformations (in category 'traits') ----- + traitTransformations + ^ self traitComposition transformations ! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>sourceCodeAt: (in category 'accessing method dictionary') ----- + sourceCodeAt: selector + + ^ (self methodDict at: selector) getSourceFor: selector in: self! Item was added: + ----- Method: ClassDescription>>isClassSide (in category 'accessing parallel hierarchy') ----- + isClassSide + ^self == self classSide! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>methodDictionary (in category 'accessing method dictionary') ----- + methodDictionary + "Convenience" + ^self methodDict! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>commentStamp: (in category 'fileIn/Out') ----- + commentStamp: changeStamp + self organization commentStamp: changeStamp. + ^ self commentStamp: changeStamp prior: 0! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>sendCaches: (in category 'send caches') ----- + sendCaches: aSendCaches + ^ self explicitRequirement! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>>> (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 added: + ----- Method: Behavior>>isDisabledSelector: (in category 'testing method dictionary') ----- + isDisabledSelector: selector + ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! Item was added: + ----- Method: Behavior>>deepCopy (in category 'copying') ----- + deepCopy + "Classes should only be shallowCopied or made anew." + + ^ self shallowCopy! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>defaultMethodTrailer (in category 'compiling') ----- + defaultMethodTrailer + ^ CompiledMethodTrailer empty! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>compilerClass (in category 'compiling') ----- + compilerClass + "Answer a compiler class appropriate for source methods of this class." + + ^Compiler! Item was added: + ----- Method: ClassDescription>>printCategoryChunk:on: (in category 'fileIn/Out') ----- + printCategoryChunk: categoryName on: aFileStream + ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! Item was added: + ----- Method: Behavior>>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 added: + ----- Method: ClassDescription>>noteCompilationOf:meta: (in category 'compiling') ----- + noteCompilationOf: aSelector meta: isMeta + "A hook allowing some classes to react to recompilation of certain selectors"! Item was added: + ----- Method: Behavior>>addToComposition: (in category 'traits') ----- + addToComposition: aTrait + self setTraitComposition: (self traitComposition copyTraitExpression + add: aTrait; + yourself)! Item was added: + ----- Method: Behavior>>setRequiredStatusOf:to: (in category 'send caches') ----- + setRequiredStatusOf: selector to: aBoolean + aBoolean + ifTrue: [self requiredSelectorsCache addRequirement: selector] + ifFalse: [self requiredSelectorsCache removeRequirement: selector].! Item was added: + ----- Method: Behavior>>traitCompositionString (in category 'traits') ----- + traitCompositionString + ^self hasTraitComposition + ifTrue: [self traitComposition asString] + ifFalse: ['{}']! Item was added: + ----- Method: Behavior>>traitCompositionIncludes: (in category 'traits') ----- + traitCompositionIncludes: aTrait + ^self == aTrait or: + [self hasTraitComposition and: + [self traitComposition allTraits includes: aTrait]]! Item was added: + ----- Method: Behavior>>setTraitCompositionFrom: (in category 'traits') ----- + setTraitCompositionFrom: aTraitExpression + ^ self setTraitComposition: aTraitExpression asTraitComposition! Item was added: + ----- Method: Behavior>>sourceCodeAt:ifAbsent: (in category 'accessing method dictionary') ----- + sourceCodeAt: selector ifAbsent: aBlock + + ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! Item was added: + ----- Method: ClassDescription>>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 added: + ----- Method: Behavior>>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 added: + ----- Method: Behavior>>methodsDo: (in category 'accessing method dictionary') ----- + methodsDo: aBlock + "Evaluate aBlock for all the compiled methods in my method dictionary." + + ^ self methodDict valuesDo: aBlock!

1 0

The Trunk: Traits-ar.254.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Traits to project The Trunk: http://source.squeak.org/trunk/Traits-ar.254.mcz ==================== Summary ==================== Name: Traits-ar.254 Author: ar Time: 29 December 2009, 4:39:15 am UUID: 299d99f4-3397-994e-bda6-007fbf65caa7 Ancestors: Traits-ar.253 Shipping NanoTraits part 2: Commit package back after NanoTraits install. =============== Diff against Traits-ar.253 =============== Item was added: + ----- Method: Behavior>>providedSelectors (in category '*Traits') ----- + providedSelectors + ^ProvidedSelectors current for: self!

1 0

The Trunk: Traits-ar.253.mcz
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Andreas Raab uploaded a new version of Traits to project The Trunk: http://source.squeak.org/trunk/Traits-ar.253.mcz ==================== Summary ==================== Name: Traits-ar.253 Author: ar Time: 29 December 2009, 4:27:03 am UUID: aacbbb6c-5526-f04e-927d-4461d769972f Ancestors: Traits-ar.252 Install NanoTraits. =============== Diff against Traits-ar.251 =============== Item was added: + ----- Method: ClassDescription>>traitAddSelector:withMethod: (in category '*Traits-NanoKernel') ----- + traitAddSelector: selector withMethod: traitMethod + "Add a method inherited from a trait. + Recompiles to avoid sharing and implement aliasing." + | oldMethod source methodNode newMethod originalSelector | + oldMethod := self compiledMethodAt: selector ifAbsent:[nil]. + oldMethod ifNotNil:[ + "The following is an important optimization as it prevents exponential + growth in recompilation. If T1 is used by T2 and T2 by T3 then (without + this optimization) any change in T1 would cause all methods in T2 to be + recompiled and each recompilation of a method in T2 would cause T3 + to be fully recompiled. The test eliminates all such situations." + (oldMethod sameTraitCodeAs: traitMethod) ifTrue:[^oldMethod]. + ]. + originalSelector := traitMethod selector. + source := traitMethod methodClass sourceCodeAt: originalSelector. + originalSelector == selector ifFalse:[ + "Replace source selectors for aliases" + source := self replaceSelector: originalSelector withAlias: selector in: source. + ]. + methodNode := self compilerClass new + compile: source in: self classified: nil notifying: nil ifFail:[^nil]. + newMethod := methodNode generate: self defaultMethodTrailer. + newMethod putSource: source fromParseNode: methodNode inFile: 2 + withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. + newMethod originalTraitMethod: traitMethod. + ^super addSelectorSilently: selector withMethod: newMethod.! Item was added: + ----- Method: ClassDescription>>isLocalMethod: (in category '*Traits-NanoKernel') ----- + isLocalMethod: aCompiledMethod + "Answer true if the method is a local method, e.g., defined in the receiver instead of a trait." + ^aCompiledMethod methodHome == self! Item was added: + ----- Method: Metaclass>>updateTraitsFrom: (in category '*Traits-NanoKernel') ----- + updateTraitsFrom: instanceTraits + "Update me from the given instance traits" + | map newTraits trait | + ((instanceTraits isKindOf: NanoTraitComposition) or:[instanceTraits isEmpty]) + ifFalse:[self error: 'Invalid trait']. + + map := Dictionary new. + self traitComposition isEmpty ifFalse:[ + self traitComposition do:[:composed| map at: composed trait put: composed]. + ]. + + newTraits := (instanceTraits collect:[:composed| + trait := composed trait classTrait. + map at: trait ifAbsent:[trait]]). + + self traitComposition isEmpty ifFalse:[ + newTraits := newTraits, (self traitComposition select:[:comp| comp trait isBaseTrait]). + ]. + self installTraitsFrom: newTraits! Item was added: + ----- Method: NanoTrait>>baseTrait (in category 'accessing') ----- + baseTrait + ^self! Item was added: + ----- Method: NanoTraitDescription>>traitComposition: (in category 'accessing') ----- + traitComposition: aTraitComposition + traitComposition := aTraitComposition. + ! Item was added: + ----- Method: ClassDescription>>setTraitComposition: (in category '*Traits-NanoKernel') ----- + setTraitComposition: aTraitComposition + "OBSOLETE. Use Class uses: aTraitComposition instead." + (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 added: + ----- Method: NanoClassTrait>>soleInstance (in category 'accessing') ----- + soleInstance + ^baseTrait! Item was added: + ----- Method: NanoTraitDescription>>isClassTrait (in category 'testing') ----- + isClassTrait + ^false! Item was added: + ----- Method: NanoTraitComposition>>isAliasSelector: (in category 'operations') ----- + isAliasSelector: selector + "enumerates all selectors and methods in a trait composition" + ^self anySatisfy:[:any| any isAliasSelector: selector]! Item was added: + ----- Method: NanoTraitTransformation>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aTrait + users := users copyWith: aTrait. + subject addTraitUser: aTrait. + ! Item was added: + ----- Method: NanoTrait class>>updateTraits: (in category 'installing') ----- + updateTraits: aCollection + "Convert all the traits in aCollection to NanoTraits. Used during installation." + "ClassDescription traitImpl: NanoTrait. + NanoTrait updateTraits:{ + TSequencedStreamTest. TGettableStreamTest. TReadStreamTest. + TStreamTest. TPuttableStreamTest. TWriteStreamTest + }" + | remain processed classes oldTrait classDef newTrait count instTraits classSelectors | + ClassDescription traitImpl == self ifFalse:[self error: 'What are you doing???']. + remain := (aCollection reject:[:tc| tc isKindOf: self]) asSet. + processed := Set new. + classes := Set new. + count := 0. + 'Converting ....' displayProgressAt: Sensor cursorPoint from: 1 to: remain size during:[:bar| + [remain isEmpty] whileFalse:[ + "Pick any trait whose traits are already converted" + oldTrait := remain detect:[:any| + any traitComposition traits allSatisfy:[:t| (Smalltalk at: t name) isKindOf: self]. + ] ifNone:[self error: 'Cannot convert cyclic traits']. + remain remove: oldTrait. + + bar value: (count := count +1). + ProgressNotification signal: '' extra: 'Converting ', oldTrait name. + + "Silently remove the old trait class and recreate it based on NanoTrait" + classDef := oldTrait definition. + Smalltalk removeKey: oldTrait name. + + "Create the NanoTrait from the same definition" + newTrait := Compiler evaluate: classDef. + + "Update comment" + oldTrait organization classComment ifNotEmpty:[ + newTrait classComment: oldTrait organization commentRemoteStr + stamp: oldTrait organization commentStamp. + ]. + + "Copy local methods to new trait" + oldTrait localSelectors do:[:sel| + newTrait + compile: (oldTrait sourceCodeAt: sel) + classified: (oldTrait organization categoryOfElement: sel) + withStamp: (oldTrait compiledMethodAt: sel) timeStamp + notifying: nil + ]. + oldTrait classSide localSelectors do:[:sel| + newTrait classSide + compile: (oldTrait classSide sourceCodeAt: sel) + classified: (oldTrait classSide organization categoryOfElement: sel) + withStamp: (oldTrait classSide compiledMethodAt: sel) timeStamp + notifying: nil + ]. + + newTrait selectors sort = oldTrait selectors sort + ifFalse:[self error: 'Something went VERY wrong']. + newTrait classSide selectors sort = oldTrait classSide selectors sort + ifFalse:[self error: 'Something went VERY wrong']. + + processed add: oldTrait. + classes addAll: (oldTrait users reject:[:aClass| aClass isObsolete]). + ]. + ]. + + classes := classes asArray select:[:cls| cls isKindOf: ClassDescription]. + 'Updating ....' displayProgressAt: Sensor cursorPoint from: 1 to: classes size during:[:bar| + "The traits are all converted, next update the classes" + classes keysAndValuesDo:[:index :aClass| + bar value: index. + ProgressNotification signal: '' extra: 'Updating ', aClass name. + + instTraits := Compiler evaluate: aClass traitComposition asString. + "Keep the local selectors from before" + localSelectors := aClass localSelectors. + classSelectors := aClass class localSelectors. + "Nuke the old traits composition" + aClass traitComposition: nil. + aClass class traitComposition: nil. + "Install the new one" + aClass uses: instTraits. + "Remove the old trait (now local) selectors" + (aClass selectors reject:[:sel| localSelectors includes: sel]) do:[:sel| + aClass removeSelectorSilently: sel. + (aClass includesSelector: sel) ifFalse:[self halt: 'Where is the code?']. + ]. + (aClass class selectors reject:[:sel| classSelectors includes: sel]) do:[:sel| + aClass class removeSelectorSilently: sel. + (aClass class includesSelector: sel) ifFalse:[self halt: 'Where is the code?']. + ]. + ]. + ]. + + "Finally, obsolete all the old traits" + processed do:[:trait| trait obsolete]. + ! Item was added: + ----- Method: NanoTraitDescription>>@ (in category 'operations') ----- + @ anArrayOfAssociations + "Creates an alias" + ^ NanoTraitAlias with: self aliases: anArrayOfAssociations! Item was added: + ----- Method: ClassDescription>>traitRemoveSelector: (in category '*Traits-NanoKernel') ----- + traitRemoveSelector: 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. + SystemChangeNotifier uniqueInstance doSilently: [ + self organization removeElement: selector]. + super basicRemoveSelector: selector. + SystemChangeNotifier uniqueInstance + methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self. + (self organization isEmptyCategoryNamed: priorProtocol) + ifTrue:[self organization removeCategory: priorProtocol]. + ! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTraitComposition>>@ (in category 'converting') ----- + @ anArrayOfAssociations + "the modifier operators #@ and #- bind stronger than +. + Thus, #@ or #- sent to a sum will only affect the most right summand" + + self addLast: (self removeLast @ anArrayOfAssociations)! Item was added: + ----- Method: NanoTraitDescription>>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 added: + ----- Method: NanoClassTrait>>theNonMetaClass (in category 'accessing') ----- + theNonMetaClass + "Sent to a class or metaclass, always return the class" + ^baseTrait! Item was added: + ----- Method: NanoTraitExclusion>>@ (in category 'converting') ----- + @ anArrayOfAssociations + + NanoTraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.' + ! Item was added: + ----- Method: NanoTraitExclusion>>includesSelector: (in category 'composition') ----- + includesSelector: selector + "Answers true if the receiver provides the selector" + ^(subject includesSelector: selector) and:[(exclusions includes: selector) not]! Item was added: + ----- Method: NanoTraitTransformation>>isAliasSelector: (in category 'testing') ----- + isAliasSelector: selector + ^subject isAliasSelector: selector! Item was added: + ----- Method: NanoTrait>>obsolete (in category 'initialize') ----- + obsolete + self name: ('AnObsolete' , self name) asSymbol. + super obsolete! Item was added: + ----- Method: NanoTraitComposition>>isLocalAliasSelector: (in category 'operations') ----- + isLocalAliasSelector: selector + "Return true if the selector aSymbol is an alias defined in the receiver." + ^self anySatisfy:[:any| any isTraitTransformation and:[any isLocalAliasSelector: selector]]! Item was added: + ----- Method: NanoTraitTransformation>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aTrait + users := users copyWithout: aTrait. + subject removeTraitUser: aTrait.! Item was added: + ----- Method: NanoTraitTransformation>>allTraits (in category 'accessing') ----- + allTraits + ^subject allTraits! Item was added: + ----- Method: NanoTraitDescription>>installTraitsFrom: (in category 'operations') ----- + installTraitsFrom: aTraitComposition + super installTraitsFrom: aTraitComposition. + self users do:[:each| each updateTraits].! Item was added: + ----- Method: NanoTraitTransformation>>@ (in category 'converting') ----- + @ anArrayOfAssociations + ^self subclassResponsibility! Item was added: + ----- Method: NanoTrait class>>named:uses:category: (in category 'public') ----- + named: aSymbol uses: aTraitCompositionOrCollection category: aString + "Dispatch through ClassDescription for alternative implementations" + ^ClassDescription newTraitNamed: aSymbol uses: aTraitCompositionOrCollection category: aString! Item was added: + NanoTraitTransformation subclass: #NanoTraitAlias + instanceVariableNames: 'aliases' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitAlias commentStamp: '<historical>' prior: 0! + A trait transformation representing the alias (->) operator.! Item was added: + ----- Method: NanoTraitDescription>>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 added: + ----- Method: NanoTraitTransformation>>isLocalAliasSelector: (in category 'testing') ----- + isLocalAliasSelector: selector + ^false! Item was added: + ----- Method: NanoTraitTransformation>>updateTraits (in category 'operations') ----- + updateTraits + "Recompute my users traits composition" + users do:[:each| each updateTraits].! Item was added: + ----- Method: NanoTraitDescription>>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 added: + ----- Method: NanoTrait>>isObsolete (in category 'testing') ----- + isObsolete + "Return true if the receiver is obsolete." + ^(self environment at: name ifAbsent: [nil]) ~~ self! Item was added: + ----- Method: ClassDescription>>traitComposition: (in category '*Traits-NanoKernel') ----- + traitComposition: aTraitComposition + "Install my traits" + ^self subclassResponsibility! Item was added: + ----- Method: ClassDescription>>isAliasSelector: (in category '*Traits-NanoKernel') ----- + 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 added: + ----- Method: NanoClassTrait>>classSide (in category 'accessing') ----- + classSide + ^self! Item was added: + ----- Method: Array>>asTraitComposition (in category '*Traits-NanoKernel') ----- + asTraitComposition + "For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..." + ^self isEmpty + ifFalse: [ + self size = 1 + ifTrue: [self first asTraitComposition] + ifFalse: [ + self copyWithoutFirst + inject: self first + into: [:left :right | left + right]]] + ifTrue: [ClassDescription newTraitComposition]! Item was added: + ----- Method: ClassDescription>>hasTraitComposition (in category '*Traits-NanoKernel') ----- + hasTraitComposition + ^self traitComposition notEmpty! Item was added: + ----- Method: ClassDescription>>classify:under:from:trait: (in category '*Traits-NanoKernel') ----- + classify: selector under: heading from: category trait: aTrait + "Update the organization for a trait. the dumb, unoptimized version" + self updateTraits.! Item was added: + ----- Method: ClassDescription>>localSelectors (in category '*Traits-NanoKernel') ----- + localSelectors + ^(self traitComposition isKindOf: NanoTraitComposition) + ifTrue:[self selectors select:[:sel| self includesLocalSelector: sel]] + ifFalse:[super localSelectors]. + ! Item was added: + ----- Method: NanoTraitComposition>>traitCompositionString (in category 'operations') ----- + traitCompositionString + "Answer the trait composition string (used for class definitions)" + self size = 0 ifTrue:[^'{}']. + self size = 1 ifTrue:[^self first asString]. + ^String streamContents:[:s| + self do:[:each| s nextPutAll: each asString] separatedBy:[s nextPutAll: ' + ']. + ].! Item was added: + ----- 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 added: + ----- Method: ClassDescription>>isLocalAliasSelector: (in category '*Traits-NanoKernel') ----- + isLocalAliasSelector: 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 isLocalAliasSelector: aSymbol]! Item was added: + ----- Method: ClassDescription>>updateTraits (in category '*Traits-NanoKernel') ----- + updateTraits + "Recompute my local traits composition" + (self traitComposition isKindOf: NanoTraitComposition) + ifTrue:[self installTraitsFrom: self traitComposition]. + ! Item was added: + ----- Method: NanoTraitDescription class>>conflict: (in category 'conflict methods') ----- + conflict: arg1 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoClassTrait>>definition (in category 'accessing') ----- + definition + ^String streamContents: [:stream | + stream nextPutAll: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + ].! Item was added: + ----- Method: NanoClassTrait>>baseTrait (in category 'accessing') ----- + baseTrait + ^baseTrait! Item was added: + NanoTraitBehavior subclass: #NanoTraitDescription + instanceVariableNames: 'users traitComposition' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitDescription commentStamp: 'ar 12/3/2009 23:42' prior: 0! + TraitDescription combines common behavior for both (instance) traits and (meta) class traits.! Item was added: + ----- Method: NanoTraitAlias>>printOn: (in category 'operations') ----- + printOn: s + "Answer the trait composition string (used for class definitions)" + s nextPutAll: subject asString. + s nextPutAll: ' @ {'. + aliases do:[:assoc| s print: assoc] separatedBy:[s nextPutAll:'. ']. + s nextPutAll: '}'. + ! Item was added: + ----- Method: ClassDescription>>includesLocalSelector: (in category '*Traits-NanoKernel') ----- + includesLocalSelector: selector + 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 added: + ----- Method: NanoTraitAlias>>includesSelector: (in category 'operations') ----- + includesSelector: selector + "Answers true if the receiver provides the selector" + ^(subject includesSelector: selector) or:[aliases anySatisfy:[:assoc| assoc key == selector]]! Item was added: + Error subclass: #NanoTraitCompositionException + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitCompositionException commentStamp: '<historical>' prior: 0! + Signals invalid trait compositions.! Item was added: + ----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') ----- + installTraitsFrom: aTraitComposition + "Install the traits from the given composition" + | allTraits methods oldMethod removals oldCategories | + (aTraitComposition isKindOf: NanoTraitComposition) + ifFalse:[self error: 'Invalid composition']. + (self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self]. + + "Check for cycles" + allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t]. + (allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected']. + + "XXXX: addUser/removeUser should be part of setter, but subclass + override prevents it until we've got rid of Traits mess." + self traitComposition removeTraitUser: self. + self traitComposition: aTraitComposition. + aTraitComposition addTraitUser: self. + + "Assemble the methods in a new dictionary first. + Uses a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)" + methods := Dictionary new. + + "Stick in the local methods first, since this avoids generating conflict methods unnecessarily" + self selectorsAndMethodsDo:[:sel :newMethod| + (self isLocalMethod: newMethod) + ifTrue:[methods at: sel put:newMethod]]. + + "Now assemble the traits methods" + aTraitComposition do:[:trait| + trait selectorsAndMethodsDo:[:sel :newMethod| + oldMethod := methods at: sel ifAbsentPut:[newMethod]. + newMethod == oldMethod ifFalse:["a conflict" + (self isLocalMethod: oldMethod) ifFalse:[ + methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod). + ]. + ]. + ]. + ]. + + "Apply the changes. We first add the new or changed methods." + oldCategories := Set new. + methods keysAndValuesDo:[:sel :newMethod| + oldMethod := self compiledMethodAt: sel ifAbsent:[nil]. + oldMethod == newMethod ifFalse:[ + self traitAddSelector: sel withMethod: newMethod. + (self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat]. + self organization classify: sel under: + (newMethod methodHome organization categoryOfElement: newMethod selector). + ]]. + + "Now remove the old or obsoleted ones" + removals := OrderedCollection new. + self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]]. + removals do:[:sel| self traitRemoveSelector: sel]. + + "Clean out empty categories" + oldCategories do:[:cat| + (self organization isEmptyCategoryNamed: cat) + ifTrue:[self organization removeCategory: cat]]. + + self isMeta ifFalse:[self class updateTraitsFrom: aTraitComposition].! Item was added: + ----- Method: NanoTraitDescription>>classPool (in category 'accessing') ----- + classPool + "Traits have no class pool" + ^ Dictionary new! Item was added: + ----- Method: NanoTraitAlias>>aliases: (in category 'accessing') ----- + aliases: aCollection + "Collection of associations where key is the + alias and value the original selector." + aliases := aCollection! Item was added: + Object subclass: #NanoTraitTransformation + instanceVariableNames: 'subject users' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitTransformation commentStamp: '<historical>' prior: 0! + A trait transformation is an instance of one of my concrete subclasses, TraitAlias or TraitExclusion. These represent a transformation of a trait, specified by the alias and exclusion operators. + + I define an instance variable named subject which holds the object that is transformed. Thus, an alias transformation has as its subject a trait, and a trait exclusion has as its subject either a trait alias or a trait. Each of the concrete transformation classes implement the method allSelectors according to the transformation it represents. + ! Item was added: + ----- Method: NanoTraitAlias>>isLocalAliasSelector: (in category 'testing') ----- + isLocalAliasSelector: selector + ^(aliases anySatisfy:[:assoc| assoc key == selector])! Item was added: + ----- 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." + TWriteStreamTest classTrait + uses: TSequencedStreamTest classTrait + TPuttableStreamTest classTrait + ! Item was added: + ----- Method: NanoTraitTransformation>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with Trait" + ^true! Item was added: + ----- Method: NanoTrait>>classTrait (in category 'accessing') ----- + classTrait + ^self class! Item was added: + ----- Method: NanoTraitComposition>>traits (in category 'accessing') ----- + traits + ^Array streamContents:[:s| self traitsDo:[:t| s nextPut: t]]! Item was added: + ----- Method: NanoTraitAlias class>>assertValidAliasDefinition: (in category 'instance creation') ----- + assertValidAliasDefinition: anArrayOfAssociations + "Throw an exceptions if the alias definition is not valid. + It is expected to be a collection of associations and + the number of arguments of the alias selector has to + be the same as the original selector." + + ((anArrayOfAssociations isKindOf: Collection) and: [ + anArrayOfAssociations allSatisfy: [:each | + each isKindOf: Association]]) ifFalse: [ + self error: 'Invalid alias definition: Not a collection of associations.']. + + (anArrayOfAssociations allSatisfy: [:association | + (association key numArgs = association value numArgs and: [ + (association key numArgs = -1) not])]) ifFalse: [ + NanoTraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']! Item was added: + ----- Method: NanoTraitAlias>>copyTraitExpression (in category 'operations') ----- + copyTraitExpression + "Copy all except the actual traits" + ^NanoTraitAlias + with: subject + aliases: aliases! Item was added: + ----- Method: NanoTrait>>environment (in category 'accessing') ----- + environment + ^environment! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTrait>>name (in category 'accessing') ----- + name + ^name! Item was added: + ----- Method: NanoTraitDescription>>+ (in category 'operations') ----- + + aTrait + "Creates a composition with the receiver and aTrait" + aTrait traitsDo:[:t| self == t ifTrue:[NanoTraitCompositionException + signal: 'Trait ' , self asString, ' already in composition']]. + ^NanoTraitComposition withAll: {self}, aTrait asTraitComposition! Item was added: + ----- Method: ClassDescription>>traitCompositionString (in category '*Traits-NanoKernel') ----- + traitCompositionString + "Answer the trait composition string for the receiver" + ^self traitComposition isEmpty + ifTrue:['{}'] + ifFalse:[self traitComposition asString].! Item was added: + ----- Method: ClassDescription>>uses: (in category '*Traits-NanoKernel') ----- + uses: aTraitComposition + | newTraits | + newTraits := (aTraitComposition isKindOf: NanoTrait orOf: NanoTraitTransformation) + ifTrue:[NanoTraitComposition with: aTraitComposition] + ifFalse:[(aTraitComposition isKindOf: SequenceableCollection) + ifTrue:[NanoTraitComposition withAll: aTraitComposition asArray] + ifFalse:[self error: 'Invalid traits specification']]. + self installTraitsFrom: newTraits. + ! Item was added: + ----- Method: NanoTraitComposition>>+ (in category 'converting') ----- + + aTrait + self traitsDo:[:t| (t == aTrait trait) ifTrue:[^NanoTraitCompositionException + signal: 'Trait ' , aTrait trait asString, ' already in composition']]. + self addLast: aTrait. + ^self! Item was added: + ----- Method: NanoTrait>>category (in category 'accessing') ----- + 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 | + category ifNotNilDo: [ :symbol | + ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) + ifTrue: [ ^symbol ] ]. + category := (result := SystemOrganization categoryOfElement: self name). + ^result! Item was added: + ----- Method: NanoTraitDescription>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aTrait + users := self users copyWithout: aTrait. + ! Item was added: + ----- Method: NanoTraitComposition>>allTraits (in category 'accessing') ----- + allTraits + ^self gather:[:each| each allTraits copyWith: each trait]! Item was added: + ----- Method: NanoTraitComposition>>removeTraitUser: (in category 'accessing') ----- + removeTraitUser: aUser + self do:[:each| each removeTraitUser: aUser]! Item was added: + ----- Method: ClassDescription>>replaceSelector:withAlias:in: (in category '*Traits-NanoKernel') ----- + replaceSelector: originalSelector withAlias: aliasSelector in: source + "replaces originalSelector with aliasSelector in in given source code" + | oldKeywords newKeywords args selectorWithArgs s | + oldKeywords := originalSelector keywords. + newKeywords := aliasSelector keywords. + oldKeywords size = newKeywords size ifFalse:[self error: 'Keyword mismatch']. + args := (self parserClass new parseArgsAndTemps: source asString notifying: nil) + copyFrom: 1 to: originalSelector numArgs. + selectorWithArgs := String streamContents: [:stream | + newKeywords keysAndValuesDo: [:index :keyword | + stream nextPutAll: keyword. + stream space. + args size >= index ifTrue: [ + stream nextPutAll: (args at: index); space]]]. + s := source asString readStream. + oldKeywords do: [ :each | s match: each ]. + args isEmpty ifFalse: [ s match: args last ]. + ^selectorWithArgs withBlanksTrimmed asText , s upToEnd + ! Item was added: + ----- Method: NanoTraitComposition>>removeUser: (in category 'accessing') ----- + removeUser: aUser + ^self removeTraitUser: aUser! Item was added: + ----- Method: NanoTraitComposition>>printOn: (in category 'converting') ----- + printOn: aStream + "Answer the trait composition string (used for class definitions)" + aStream nextPutAll: self traitCompositionString. + ! Item was added: + ----- Method: NanoTraitTransformation>>+ (in category 'converting') ----- + + aTrait + "Just like ordered collection" + ^NanoTraitComposition withAll: {self. aTrait}! Item was added: + ----- Method: NanoTraitAlias>>initializeFrom: (in category 'initialize-release') ----- + initializeFrom: anArrayOfAssociations + | newNames | + newNames := (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. + newNames size < anArrayOfAssociations size ifTrue: [ + NanoTraitCompositionException signal: 'Cannot use the same alias name twice']. + anArrayOfAssociations do: [:each | + (newNames includes: each value) ifTrue: [ + NanoTraitCompositionException signal: 'Cannot define an alias for an alias']]. + aliases := anArrayOfAssociations. + ! Item was added: + ----- Method: NanoTraitTransformation>>subject: (in category 'accessing') ----- + subject: aSubject + subject := aSubject.! Item was added: + ----- Method: NanoTrait class>>unloadNanoTraits (in category 'installing') ----- + unloadNanoTraits + "Unload NanoTraits" + ClassDescription traitImpl == self + ifTrue:[ClassDescription traitImpl: nil]. + + CompiledMethod allInstancesDo:[:cm| + "Clean out NanoTraitState for all methods; this makes all methods local" + (cm properties isKindOf: NanoTraitMethodState) ifTrue:[ + cm penultimateLiteral: (AdditionalMethodState newFrom: cm properties). + ]. + ]. + + self allTraitsDo:[:trait| + "Clean out the existing users for this trait" + trait users do:[:user| user uses: {}]. + ]. + + "We need a stub updateTraits method during unload" + [Behavior halt compileSilently: 'updateTraits' classified: nil. + "Finally, unload NanoTraits" + (MCPackage named: 'NanoTraits') unload. + ] ensure:[Behavior removeSelectorSilently: #updateTraits]. + + Smalltalk allClassesAndTraitsDo:[:aClass| + "Clean out existing NanoTraitCompositions" + (aClass traitComposition class isObsolete) + ifTrue:[aClass traitComposition: #()]. + (aClass classSide traitComposition class isObsolete) + ifTrue:[aClass classSide traitComposition: #()]. + ]. + + Smalltalk at: #Trait ifPresent:[:aClass| + aClass isObsolete ifTrue:[Smalltalk at: #Trait put: nil]. + ]. + + Compiler recompileAll.! Item was added: + ----- Method: NanoTrait>>bindingOf: (in category 'compiling') ----- + bindingOf: varName + "Answer the binding of some variable resolved in the scope of the receiver" + ^self environment bindingOf: varName asSymbol.! Item was added: + ----- Method: NanoTraitExclusion>>printOn: (in category 'composition') ----- + printOn: aStream + "Answer the trait composition string (used for class definitions)" + aStream nextPutAll: subject asString. + aStream nextPutAll: ' - {'. + exclusions asArray sort do:[:exc| aStream store: exc] separatedBy:[aStream nextPutAll: '. ']. + aStream nextPutAll: '}'.! Item was added: + ----- Method: ClassDescription>>basicRemoveSelector: (in category '*Traits-NanoKernel') ----- + basicRemoveSelector: aSelector + "Remove the message whose selector is given from the method + dictionary of the receiver, if it is there. Update the trait composition." + | oldMethod | + oldMethod := super basicRemoveSelector: aSelector. + oldMethod ifNotNil:[self updateTraits]. + ^oldMethod! Item was added: + ----- Method: ClassDescription>>traits (in category '*Traits-NanoKernel') ----- + traits + "Answer an array of my traits" + ^self traitComposition asArray collect:[:composed| composed trait]! Item was added: + ----- Method: NanoClassTrait>>asMCDefinition (in category 'monticello') ----- + asMCDefinition + ^Smalltalk at: #MCClassTraitDefinition ifPresent:[:aClass| + aClass + baseTraitName: self baseTrait name + classTraitComposition: self traitCompositionString + ].! Item was added: + ----- Method: NanoTraitDescription>>copyTraitExpression (in category 'copying') ----- + copyTraitExpression + "Copy all except the actual traits" + ^self! Item was added: + ----- Method: NanoTraitDescription>>users (in category 'accessing') ----- + users + ^users ifNil:[#()]! Item was added: + ----- Method: NanoTraitComposition>>removeFromComposition: (in category 'compat') ----- + removeFromComposition: aTrait + "--- ignore ---"! Item was added: + ----- Method: NanoTraitComposition>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + self do:[:each| each selectorsAndMethodsDo: aBlock].! Item was added: + ----- Method: NanoTraitComposition>>copyTraitExpression (in category 'operations') ----- + copyTraitExpression + "Copy all except the actual traits" + ^self collect:[:each| each copyTraitExpression].! Item was added: + ----- Method: NanoTraitExclusion class>>with:exclusions: (in category 'instance creation') ----- + with: aTraitComposition exclusions: anArrayOfSelectors + ^self new + subject: aTraitComposition; + exclusions: anArrayOfSelectors; + yourself + ! Item was added: + ----- Method: NanoTraitExclusion>>selectorsAndMethodsDo: (in category 'composition') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + ^subject selectorsAndMethodsDo:[:sel :meth| + (exclusions includes: sel) ifFalse:[aBlock value: sel value: meth]. + ].! Item was added: + ----- Method: NanoTraitExclusion>>copyTraitExpression (in category 'composition') ----- + copyTraitExpression + "Copy all except the actual traits" + ^NanoTraitExclusion + with: subject + exclusions: exclusions asArray! Item was added: + NanoTraitTransformation subclass: #NanoTraitExclusion + instanceVariableNames: 'exclusions' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitExclusion commentStamp: '<historical>' prior: 0! + A trait transformation representing the exclusion (-) operator.! Item was added: + ----- Method: NanoTrait>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- + fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex + super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. + self classSide hasMethods ifTrue:[ + aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. + self classSide + fileOutOn: aFileStream + moveSource: moveSource + toFile: fileIndex].! 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 added: + ----- Method: NanoTrait>>classDefinitions (in category 'monticello') ----- + classDefinitions + | definitions | + definitions := OrderedCollection with: self asClassDefinition. + (self hasClassTrait + and: [self classTrait hasTraitComposition] + and: [self classTrait traitComposition isEmpty not]) + ifTrue: [definitions add: self classTrait asMCDefinition]. + ^definitions asArray! Item was added: + ----- Method: NanoClassTrait>>isClassTrait (in category 'testing') ----- + isClassTrait + ^true! Item was added: + ----- Method: ClassDescription>>allTraits (in category '*Traits-NanoKernel') ----- + allTraits + "Answer all the traits that are used by myself without their transformations" + ^self traitComposition isEmpty + ifTrue:[#()] + ifFalse:[self traitComposition allTraits].! Item was added: + ----- Method: NanoTraitTransformation>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + ^self subclassResponsibility! Item was added: + ----- Method: NanoClassTrait>>theMetaClass (in category 'accessing') ----- + theMetaClass + ^self! Item was added: + ----- Method: NanoTraitTransformation>>copyTraitExpression (in category 'operations') ----- + copyTraitExpression + "Copy all except the actual traits" + ^self subclassResponsibility! Item was added: + ----- Method: NanoTrait>>asClassDefinition (in category 'monticello') ----- + asClassDefinition + ^Smalltalk at: #MCTraitDefinition ifPresent:[:aClass| + aClass + name: self name + traitComposition: self traitCompositionString + category: self category + comment: self organization classComment asString + commentStamp: self organization commentStamp].! Item was added: + ----- Method: NanoTraitDescription>>sharedPools (in category 'accessing') ----- + sharedPools + "Traits have no shared pools" + ^ Dictionary new! Item was added: + ----- Method: NanoClassTrait>>definitionST80 (in category 'accessing') ----- + definitionST80 + ^String streamContents: [:stream | + stream nextPutAll: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + ].! Item was added: + ----- Method: NanoTraitAlias>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + aliases := #().! Item was added: + ----- Method: NanoTrait class>>newTemplateIn: (in category 'public') ----- + newTemplateIn: categoryString + ^String streamContents: [:stream | + stream + nextPutAll: 'Trait named: #NameOfTrait'; + cr; tab; + nextPutAll: 'uses: {}'; + cr; tab; + nextPutAll: 'category: '; + nextPut: $'; + nextPutAll: categoryString; + nextPut: $' ]! Item was added: + ----- Method: NanoTrait class>>newTraitNamed:uses:category: (in category 'public') ----- + 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 added: + ----- Method: NanoTraitExclusion>>exclusions: (in category 'accessing') ----- + exclusions: aCollection + exclusions := Set withAll: aCollection! Item was added: + ----- Method: AdditionalMethodState>>originalTraitMethod (in category '*Traits-NanoKernel') ----- + originalTraitMethod + "The original method from the trait. + Only available in TraitMethodState." + ^nil! Item was added: + ----- Method: NanoTraitDescription>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with TraitTransformation" + ^false! Item was added: + ----- Method: NanoTraitExclusion>>- (in category 'converting') ----- + - anArrayOfSelectors + ^NanoTraitExclusion + with: subject + exclusions: (anArrayOfSelectors, exclusions asArray)! Item was added: + ----- Method: ClassDescription>>resolveTraitsConflict:from:to: (in category '*Traits-NanoKernel') ----- + resolveTraitsConflict: aSelector from: oldMethod to: newMethod + "Resolve a traits conflict. Rules: + - If one method is required the other one wins + - Otherwise we compile a traits conflict + " + | marker selector | + oldMethod methodHome == newMethod methodHome ifTrue:[^oldMethod]. + marker := oldMethod markerOrNil. + (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) + ifTrue:[^newMethod]. + marker := newMethod markerOrNil. + (#(requirement explicitRequirement subclassResponsibility shouldNotImplement) includes: marker) + ifTrue:[^oldMethod]. + "Create a conflict marker" + selector := #(conflict conflict: conflict:with: conflict:with:with: conflict:with:with:with: + conflict:with:with:with:with: conflict:with:with:with:with:with: conflict:with:with:with:with:with:with: + conflict:with:with:with:with:with:with:with:) at: oldMethod numArgs+1. + ^NanoTraitDescription class compiledMethodAt: selector.! Item was added: + ----- Method: NanoTraitComposition>>isTraitTransformation (in category 'testing') ----- + isTraitTransformation + "Polymorphic with TraitTransformation" + ^false! Item was added: + ----- Method: NanoTrait>>rename: (in category 'initialize') ----- + 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 added: + ----- Method: AdditionalMethodState>>originalTraitOrClass (in category '*Traits-NanoKernel') ----- + originalTraitOrClass + "The original trait for this method" + ^method methodClass! Item was added: + ----- Method: ClassDescription>>users (in category '*Traits-NanoKernel') ----- + users + ^#()! Item was added: + ----- Method: CompiledMethod>>originalTraitMethod: (in category '*Traits-NanoKernel') ----- + originalTraitMethod: aCompiledMethod + "Remember the original trait method for the receiver." + | methodState | + methodState := NanoTraitMethodState newFrom: self properties. + methodState originalTraitMethod: aCompiledMethod. + self penultimateLiteral: methodState.! Item was added: + ----- Method: NanoTraitComposition>>includesTrait: (in category 'testing') ----- + includesTrait: aTrait + ^self anySatisfy:[:each| each includesTrait: aTrait]! Item was added: + ----- Method: NanoTrait>>isBaseTrait (in category 'testing') ----- + isBaseTrait + ^true! Item was added: + ----- Method: CompiledMethod>>sameTraitCodeAs: (in category '*Traits-NanoKernel') ----- + sameTraitCodeAs: method + "Answer whether the receiver implements the same code as the + argument, method. Does not look at properties/pragmas since they + do not affect the resulting code." + | numLits | + (method isKindOf: CompiledMethod) ifFalse: [^false]. + self methodHome == method methodHome ifFalse:[^false]. + (self properties analogousCodeTo: method properties) ifFalse:[^false]. + self size = method size ifFalse: [^false]. + self header = method header ifFalse: [^false]. + self initialPC to: self endPC do:[:i | (self at: i) = (method at: i) ifFalse: [^false]]. + (numLits := self numLiterals) ~= method numLiterals ifTrue: [^false]. + 1 to: numLits-2 do:[:i| | lit1 lit2 | + lit1 := self literalAt: i. + lit2 := method literalAt: i. + lit1 = lit2 ifFalse:[ + (i = 1 and: [#(117 120) includes: self primitive]) ifTrue: [ + lit1 isArray ifTrue:[ + (lit2 isArray and: [lit1 allButLast = lit2 allButLast]) ifFalse:[^false] + ] ifFalse: "ExternalLibraryFunction" + [(lit1 analogousCodeTo: lit2) ifFalse:[^false]]. + ] ifFalse:[ + lit1 isFloat + ifTrue:[(lit1 closeTo: lit2) ifFalse: [^false]] + ifFalse:["any other discrepancy is a failure"^ false]]]]. + ^true! Item was added: + ----- Method: NanoTraitDescription>>addSelectorSilently:withMethod: (in category 'operations') ----- + addSelectorSilently: selector withMethod: compiledMethod + "Overridden to update the users of this trait" + super addSelectorSilently: selector withMethod: compiledMethod. + self users do:[:each| each updateTraits].! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTrait class>>newTraitComposition (in category 'public') ----- + newTraitComposition + "Creates a new TraitComposition" + ^NanoTraitComposition new! Item was added: + ----- Method: NanoTrait class>>named:uses:category:env: (in category 'instance creation') ----- + named: aSymbol uses: aTraitComposition category: aString env: anEnvironment + | trait oldTrait systemCategory oldCategory | + systemCategory := aString asSymbol. + oldTrait := anEnvironment at: aSymbol ifAbsent: [nil]. + oldTrait ifNil:[ + trait := NanoClassTrait new new. + ] ifNotNil:[ + oldCategory := oldTrait category. + trait := oldTrait. + ]. + (trait isKindOf: NanoTrait) ifFalse: [ + ^self error: trait name , ' is not a Trait']. + trait + setName: aSymbol + andRegisterInCategory: systemCategory + environment: anEnvironment. + + trait uses: aTraitComposition. + + "... notify interested clients ..." + oldTrait ifNil:[ + SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory. + ] ifNotNil:[ + systemCategory = oldCategory ifFalse:[ + SystemChangeNotifier uniqueInstance class: trait + recategorizedFrom: oldTrait category to: systemCategory]. + ]. + ^ trait! Item was added: + ----- Method: NanoTraitTransformation>>traitsDo: (in category 'accessing') ----- + traitsDo: aBlock + ^subject traitsDo: aBlock! Item was added: + ----- Method: NanoTraitAlias>>selectorsAndMethodsDo: (in category 'operations') ----- + selectorsAndMethodsDo: aBlock + "enumerates all selectors and methods in a trait composition" + subject selectorsAndMethodsDo:[:sel :meth| + aBlock value: sel value: meth. + ]. + aliases do:[:assoc| | method | + "Method can be nil during removals" + method := subject compiledMethodAt: assoc value ifAbsent:[nil]. + method ifNotNil:[aBlock value: assoc key value: method]. + ].! Item was added: + ----- Method: NanoClassTrait>>bindingOf: (in category 'compiling') ----- + bindingOf: varName + "Answer the binding of some variable resolved in the scope of the receiver" + ^baseTrait bindingOf: varName! Item was added: + ----- Method: NanoTraitDescription>>copy (in category 'copying') ----- + copy + self error: 'Traits cannot be trivially copied'! Item was added: + ----- Method: NanoTraitTransformation>>includesTrait: (in category 'testing') ----- + includesTrait: aTrait + ^subject includesTrait: aTrait! Item was added: + ----- Method: NanoTraitTransformation>>asTraitTransform (in category 'converting') ----- + asTraitTransform + ^self! Item was added: + ----- Method: NanoTrait>>removeFromSystem: (in category 'initialize') ----- + removeFromSystem: logged + self environment forgetClass: self logged: logged. + self obsolete! Item was added: + ----- Method: NanoClassTrait>>uses: (in category 'initialize') ----- + uses: aTraitComposition + | newTraits | + newTraits := (aTraitComposition isTrait or:[aTraitComposition isTraitTransformation]) + ifTrue:[NanoTraitComposition with: aTraitComposition] + ifFalse:[(aTraitComposition isKindOf: SequenceableCollection) + ifTrue:[NanoTraitComposition withAll: aTraitComposition asArray] + ifFalse:[self error: 'Invalid traits specification']]. + newTraits traitsDo:[:t| + (t isBaseTrait and:[t classSide hasMethods]) + ifTrue:[self error: 'Cannot add: ', t]. + (t isClassTrait and:[(baseTrait includesTrait: t baseTrait) not]) + ifTrue:[self error: 'Cannot add: ', t]. + ]. + self installTraitsFrom: newTraits.! Item was added: + ----- Method: NanoTrait>>definition (in category 'initialize') ----- + definition + ^String streamContents: [:stream | + stream nextPutAll: 'Trait named: '; + store: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + stream cr; tab; nextPutAll: 'category: '; + store: self category asString].! Item was added: + ----- Method: NanoTraitTransformation>>trait (in category 'accessing') ----- + trait + ^subject trait! Item was added: + ----- Method: NanoTraitTransformation>>updateSelector:withTraitMethod:from: (in category 'operations') ----- + updateSelector: aSelector withTraitMethod: compiledMethod from: aTrait + "broadcasts the change of a selector to all users of a trait" + ^self subclassResponsibility! Item was added: + ----- Method: NanoTraitDescription>>addUser: (in category 'accessing') ----- + addUser: aTrait + ^self addTraitUser: aTrait! Item was added: + NanoTraitDescription subclass: #NanoClassTrait + instanceVariableNames: 'baseTrait' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoClassTrait commentStamp: '<historical>' prior: 0! + While every class has an associated metaclass, a trait can have an associated classtrait, an instance of me. To preserve metaclass compatibility, the associated classtrait (if there is one) is automatically applied to the metaclass, whenever a trait is applied to a class. Consequently, a trait with an associated classtrait can only be applied to classes, whereas a trait without a classtrait can be applied to both classes and metaclasses.! Item was added: + NanoTraitDescription subclass: #NanoTrait + instanceVariableNames: 'name environment category' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTrait commentStamp: '<historical>' prior: 0! + Each trait in the system is represented as an instance of me. Like Class, I concretize my superclass by providing instance variables for the name and the environment.! Item was added: + ----- Method: NanoClassTrait>>isMeta (in category 'testing') ----- + isMeta + ^true! Item was added: + ----- Method: NanoTraitComposition>>addUser: (in category 'accessing') ----- + addUser: aUser + ^self addTraitUser: aUser! Item was added: + ----- Method: NanoTraitDescription>>isBaseTrait (in category 'testing') ----- + isBaseTrait + ^false! Item was added: + ----- Method: NanoTraitExclusion>>initialize (in category 'initialize') ----- + initialize + super initialize. + exclusions := Set new. + ! Item was added: + ----- Method: ClassDescription>>setTraitCompositionFrom: (in category '*Traits-NanoKernel') ----- + setTraitCompositionFrom: aTraitComposition + "OBSOLETE. Use Class uses: aTraitComposition instead." + (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 added: + ----- Method: NanoTraitDescription>>removeUser: (in category 'accessing') ----- + removeUser: aTrait + ^self removeTraitUser: aTrait! Item was added: + ----- Method: NanoTraitAlias>>- (in category 'converting') ----- + - anArrayOfSelectors + ^NanoTraitExclusion + with: self + exclusions: anArrayOfSelectors! Item was added: + ----- Method: NanoTraitDescription>>asTraitComposition (in category 'converting') ----- + asTraitComposition + ^NanoTraitComposition with: self! Item was added: + ----- Method: NanoTraitAlias class>>with:aliases: (in category 'instance creation') ----- + with: aTraitComposition aliases: anArrayOfAssociations + self assertValidAliasDefinition: anArrayOfAssociations. + ^self new + subject: aTraitComposition; + initializeFrom: anArrayOfAssociations; + yourself! Item was added: + ----- Method: NanoTrait>>isValidTraitName: (in category 'initialize') ----- + isValidTraitName: aSymbol + ^(aSymbol isEmptyOrNil + or: [aSymbol first isLetter not] + or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not! Item was added: + ----- Method: NanoTraitDescription>>isTrait (in category 'testing') ----- + isTrait + ^true! Item was added: + ----- Method: NanoTrait>>removeFromSystem (in category 'initialize') ----- + removeFromSystem + self removeFromSystem: true! Item was added: + ----- Method: NanoTraitComposition>>asTraitComposition (in category 'converting') ----- + asTraitComposition + ^self! Item was added: + ----- Method: NanoTraitDescription>>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: aClass on: aStream level: indent+1]. + ]. + ! Item was added: + ----- Method: NanoTraitDescription>>traitComposition (in category 'accessing') ----- + traitComposition + ^traitComposition ifNil:[traitComposition := NanoTraitComposition new] + ! Item was added: + ----- Method: NanoTrait class>>allTraitsDo: (in category 'public') ----- + allTraitsDo: aBlock + "Evaluate aBlock with all the instance and class traits present in the system" + NanoClassTrait allInstances do: [:metaTrait| + aBlock value: metaTrait instanceSide. + aBlock value: metaTrait. + ].! Item was added: + ----- Method: NanoTrait>>hasClassTrait (in category 'testing') ----- + hasClassTrait + ^true! Item was added: + ----- Method: NanoTraitTransformation>>initialize (in category 'initialize') ----- + initialize + super initialize. + users := #().! Item was added: + ----- Method: NanoTraitMethodState>>originalTraitMethod (in category 'accessing') ----- + originalTraitMethod + "The original method from the trait" + ^originalTraitMethod! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: ClassDescription>>includesTrait: (in category '*Traits-NanoKernel') ----- + includesTrait: aTrait + ^self traitComposition includesTrait: aTrait! Item was added: + ----- Method: NanoTrait>>setName:andRegisterInCategory:environment: (in category 'initialize') ----- + setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary + (self isValidTraitName: aSymbol) ifFalse: [self error:'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: [self error: '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 added: + ----- Method: NanoTraitMethodState>>originalTraitOrClass (in category 'accessing') ----- + originalTraitOrClass + "The original trait for this method" + ^originalTraitMethod originalTraitOrClass! Item was added: + ----- Method: NanoTraitDescription>>users: (in category 'accessing') ----- + users: aCollection + users := aCollection! Item was added: + ----- Method: NanoTraitTransformation>>asTraitComposition (in category 'converting') ----- + asTraitComposition + ^NanoTraitComposition with: self! Item was added: + ----- Method: CompiledMethod>>originalTraitMethod (in category '*Traits-NanoKernel') ----- + originalTraitMethod + "Remember the original trait method for the receiver." + ^self properties originalTraitMethod! Item was added: + ClassDescription subclass: #NanoTraitBehavior + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitBehavior commentStamp: 'ar 12/29/2009 15:57' prior: 0! + Stub class for backward compatibility. Allows past extension methods in TraitBehavior to continue to work.! Item was added: + ----- Method: NanoTrait>>category: (in category 'accessing') ----- + category: aString + "Categorize the receiver under the system category, aString, removing it from + any previous categorization." + + | oldCategory | + oldCategory := category. + aString isString + ifTrue: [ + category := aString asSymbol. + SystemOrganization classify: self name under: category ] + ifFalse: [self errorCategoryName]. + SystemChangeNotifier uniqueInstance + class: self recategorizedFrom: oldCategory to: category! Item was added: + ----- Method: CompiledMethod>>originalTraitOrClass (in category '*Traits-NanoKernel') ----- + originalTraitOrClass + "The original trait for this method" + ^self properties originalTraitOrClass! Item was added: + ----- Method: NanoTrait>>name: (in category 'accessing') ----- + name: aSymbol + name := aSymbol! Item was added: + AdditionalMethodState variableSubclass: #NanoTraitMethodState + instanceVariableNames: 'originalTraitMethod' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitMethodState commentStamp: '<historical>' prior: 0! + Additional method state for trait provided methods.! Item was added: + ----- Method: NanoClassTrait class>>new (in category 'instance creation') ----- + new + | newMeta | + newMeta := super new. + newMeta + superclass: NanoTrait + methodDictionary: MethodDictionary new + format: NanoTrait format. + ^newMeta! Item was added: + ----- Method: NanoTraitMethodState>>methodHome (in category 'accessing') ----- + methodHome + "The behavior (trait/class) this method was originally defined in. + Derived from the originalTraitMethod if any." + ^originalTraitMethod ifNil:[super methodHome] ifNotNil:[:m| m methodHome]! Item was added: + ----- Method: NanoTraitDescription>>notifyOfRecategorizedSelector:from:to: (in category 'operations') ----- + notifyOfRecategorizedSelector: element from: oldCategory to: newCategory + super notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. + self users do:[:each| each classify: element under: newCategory from: oldCategory trait: self].! Item was added: + ----- Method: NanoClassTrait>>instanceSide (in category 'accessing') ----- + instanceSide + ^self baseTrait! Item was added: + ----- Method: NanoTraitDescription>>- (in category 'operations') ----- + - anArrayOfSelectors + "Creates an exclusion" + ^NanoTraitExclusion + with: self + exclusions: anArrayOfSelectors! Item was added: + ----- Method: NanoTraitAlias>>isAliasSelector: (in category 'testing') ----- + isAliasSelector: selector + ^(self isLocalAliasSelector: selector) or:[super isAliasSelector: selector]! Item was added: + ----- Method: NanoTraitComposition>>- (in category 'converting') ----- + - anArray + "the modifier operators #@ and #- bind stronger than +. + Thus, #@ or #- sent to a sum will only affect the most right summand" + + self addLast: (self removeLast - anArray)! Item was added: + ----- Method: NanoTrait class>>initialize (in category 'initialize') ----- + initialize + "Install NanoTraits" + self install. + ! Item was added: + ----- Method: ClassDescription>>traitComposition (in category '*Traits-NanoKernel') ----- + traitComposition + "Answer my trait composition" + ^#()! Item was added: + ----- Method: NanoClassTrait>>new (in category 'accessing') ----- + new + baseTrait ifNotNil:[self error: 'Already initialized']. + baseTrait := self basicNew initialize. + baseTrait + superclass: nil + methodDictionary: MethodDictionary new + format: Object format. + ^baseTrait! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTraitAlias>>@ (in category 'converting') ----- + @ anArrayOfAssociations + ^NanoTraitAlias + with: subject + aliases: (anArrayOfAssociations, self aliases)! Item was added: + ----- Method: NanoClassTrait>>updateTraitsFrom: (in category 'initialize') ----- + updateTraitsFrom: instanceTraits + "Update me from the given instance traits" + | map newTraits trait | + map := Dictionary new. + self traitComposition do:[:composed| map at: composed trait put: composed]. + newTraits := (instanceTraits collect:[:composed| + trait := composed trait classTrait. + map at: trait ifAbsent:[trait]] + ), (self traitComposition select:[:comp| comp trait isBaseTrait]). + + self installTraitsFrom: newTraits! Item was added: + ----- Method: NanoClassTrait>>name (in category 'accessing') ----- + name + ^baseTrait name, ' classTrait'! Item was added: + OrderedCollection subclass: #NanoTraitComposition + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Traits-NanoKernel'! + + !NanoTraitComposition commentStamp: '<historical>' prior: 0! + A trait composition is a collection of Traits or TraitTransformations.! Item was added: + ----- Method: NanoTraitDescription>>traitsDo: (in category 'operations') ----- + traitsDo: aBlock + aBlock value: self.! Item was added: + ----- Method: NanoTraitExclusion>>exclusions (in category 'accessing') ----- + exclusions + ^exclusions! Item was added: + ----- Method: NanoTraitMethodState>>originalTraitMethod: (in category 'accessing') ----- + originalTraitMethod: aCompiledMethod + "The original method from the trait" + originalTraitMethod := aCompiledMethod! Item was added: + ----- Method: NanoTraitComposition>>traitsDo: (in category 'accessing') ----- + traitsDo: aBlock + ^self do:[:each| each traitsDo: aBlock]! Item was added: + ----- Method: NanoTraitDescription class>>conflict (in category 'conflict methods') ----- + conflict + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTraitDescription>>allClassVarNames (in category 'accessing') ----- + allClassVarNames + "Traits have no class var names" + ^#()! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 with: arg5 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTraitTransformation>>- (in category 'converting') ----- + - anArrayOfSelectors + ^self subclassResponsibility! Item was added: + ----- Method: NanoTrait>>environment: (in category 'accessing') ----- + environment: anObject + environment := anObject! Item was added: + ----- Method: NanoTraitDescription>>includesTrait: (in category 'testing') ----- + includesTrait: aTrait + ^self == aTrait or:[super includesTrait: aTrait]! Item was added: + ----- Method: NanoTraitDescription>>trait (in category 'accessing') ----- + trait + ^self! Item was added: + ----- Method: NanoTraitDescription class>>conflict:with:with:with: (in category 'conflict methods') ----- + conflict: arg1 with: arg2 with: arg3 with: arg4 + "This method has a trait conflict" + ^self traitConflict! Item was added: + ----- Method: NanoTrait>>definitionST80 (in category 'initialize') ----- + definitionST80 + ^String streamContents: [:stream | + stream nextPutAll: 'Trait named: '; + store: self name. + stream cr; tab; nextPutAll: 'uses: '; + nextPutAll: self traitComposition asString. + stream cr; tab; nextPutAll: 'category: '; + store: self category asString].! Item was added: + ----- Method: NanoTraitDescription>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aTrait + users := self users copyWith: aTrait. + ! Item was added: + ----- Method: NanoTraitAlias>>aliases (in category 'accessing') ----- + aliases + "Collection of associations where key is the + alias and value the original selector." + ^aliases! Item was added: + ----- Method: NanoTraitComposition>>addTraitUser: (in category 'accessing') ----- + addTraitUser: aUser + self do:[:each| each addTraitUser: aUser]!

1 0

New TextDiffBuilder implementation
by Levente Uzonyi 31 Dec '09

31 Dec '09

Hi, We rewrote TextDiffBuilder using a modified version of the greedy longest common subsequence algorithm from 'An O(ND) Difference Algorithm and Its Variations (1986)' by Eugene W. Myers [1]. It's in The Inbox as: System-klub.209. The implementation is smaller, faster, gives a minimal patch and passes the tests. Old New Ratio Number of classes 5 4 0.8 Number of methods 50 29 0.58 Lines of code 387 197 0.51 We would appreciate if someone can review this before moving into trunk. Cheers, Levente & Balazs [1] http://xmailserver.org/diff2.pdf

3 3

Daily Commit Log
by commits＠source.squeak.org 31 Dec '09

31 Dec '09

Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2009-December/002225.h… Name: Network-ar.46 Ancestors: Network-ar.45 Add an HTTPProgress notification that can be used to display progress during HTTPSocket httpGet: operations. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2009-December/002226.h… Name: Monticello-ar.345 Ancestors: Monticello-ar.344 Display progress during common MC operations on HTTP repositories. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2009-December/002227.h… Name: Network-ar.47 Ancestors: Network-ar.46 Add HTTPProgress for put operations (uploads). ============================================= http://lists.squeakfoundation.org/pipermail/packages/2009-December/002228.h… Name: Monticello-ar.346 Ancestors: Monticello-ar.345 Include names of repository and package in up and download progress. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2009-December/002229.h… Name: Monticello-ar.347 Ancestors: Monticello-ar.346 Have MCPackageLoader use the best guess about the package being installed in progress notifications. ============================================= http://lists.squeakfoundation.org/pipermail/packages/2009-December/002230.h… Name: MonticelloConfigurations-ar.71 Ancestors: MonticelloConfigurations-ar.70 With the additional progress info from MC, configs are a bit noisy when updating. Suppress a good chunk of progress depending (for now) on a preference. The result are smoother and less noisy progress notifications during updates. =============================================

1 0

Integer>>isPrime why reverting Knuth's algorithm P (probabilistic primality test) with iteration over division with even numbers?
by Enrico Spinielli 31 Dec '09

31 Dec '09

Hi all, I am back to checking Squeak after quite a while and got latest trunk. I looked after one of my contributions Integer>>isPrime and I found my implementation of Algorithm P from Knuth's AOCP vol 2 substituted by an iteration of dividing self by all even numbers starting from 3 and (correctly) stopping at self sqrtFloor. This is IMHO a questionable/useless "improvement", not even looking to try to implement the Sieve of Eratostene...! Again IMHO isPrime should be reverted back to what has been renamed isProbablyPrime Not being anymore used to contribute I just signal it here... Hope it helps Bye -- Enrico Spinielli "Do Androids dream of electric sheep?"— Philip K. Dick "Hear and forget; see and remember;do and understand."—Mitchel Resnick

7 14

← Newer
1
2
3
4
5
6
7
8
...
56
Older →

Jump to page: