Squeak-dev December 2009

squeak-dev@lists.squeakfoundation.org

97 participants
553 discussions

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

31 Dec '09

Andreas Raab uploaded a new version of Collections to project The Trunk: http://source.squeak.org/trunk/Collections-ar.268.mcz ==================== Summary ==================== Name: Collections-ar.268 Author: ar Time: 31 December 2009, 8:00:38 am UUID: d7d8920f-95b8-bd48-80d1-ccca70274fb6 Ancestors: Collections-ul.267 Enhancements to Collection>>do:displayingProgress:. The new version has two additional features: It allows the provision of a block argument for the label instead of a string, i.e., Smalltalk allClasses do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress:[:aClass| 'Processing ', aClass name] The second addition is an update limit that ensures that we're not spending our time in display updates. When the update limit is zero, we will update every round through the iteration, see: (Smalltalk allClasses) do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress:[:aClass| 'Processing ', aClass name] every: 0. whereas with non-zero argument we only do this every n msecs: (Smalltalk allClasses) do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress:[:aClass| 'Processing ', aClass name] every: 200. The default update limit is 20ms which should be a pretty good general choice. =============== Diff against Collections-ul.267 =============== Item was changed: ----- Method: Collection>>do:displayingProgress: (in category 'enumerating') ----- + do: aBlock displayingProgress: aStringOrBlock + "Enumerate aBlock displaying progress information. + If the argument is a string, use a static label for the process. + If the argument is a block, evaluate it with the element to retrieve the label. + Smalltalk allClasses + do:[:aClass| (Delay forMilliseconds: 1) wait] + displayingProgress: 'Processing...'. + Smalltalk allClasses + do:[:aClass| (Delay forMilliseconds: 1) wait] + displayingProgress:[:aClass| 'Processing ', aClass name]. + " + ^self do: aBlock displayingProgress: aStringOrBlock every: 20! - do: aBlock displayingProgress: aString - - aString - displayProgressAt: Sensor cursorPoint - from: 0 to: self size - during: - [:bar | - self inject: 1 into: - [:index :each | - bar value: index. - aBlock value: each. - index + 1]]! Item was added: + ----- Method: Collection>>do:displayingProgress:every: (in category 'enumerating') ----- + do: aBlock displayingProgress: aStringOrBlock every: msecs + "Enumerate aBlock displaying progress information. + If the argument is a string, use a static label for the process. + If the argument is a block, evaluate it with the element to retrieve the label. + The msecs argument ensures that updates happen at most every msecs. + Example: + Smalltalk allClasses + do:[:aClass| (Delay forMilliseconds: 1) wait] + displayingProgress:[:aClass| 'Processing ', aClass name] + every: 0. + Smalltalk allClasses + do:[:aClass| (Delay forMilliseconds: 1) wait] + displayingProgress:[:aClass| 'Processing ', aClass name] + every: 100. + " + | count size labelBlock oldLabel newLabel lastUpdate | + labelBlock := aStringOrBlock isString + ifTrue:[[:item| aStringOrBlock]] + ifFalse:[aStringOrBlock]. + count := 0. + size := self size. + '' displayProgressAt: Sensor cursorPoint from: 0 to: size during:[:bar | + self do:[:each| + "Special handling for initial progress" + (count = 0 or:[count = size]) ifTrue:[ + bar value: count. + ProgressNotification signal: '' extra: (oldLabel := labelBlock value: each). + lastUpdate := Time millisecondClockValue. + ]. + aBlock value: each. + count := count + 1. + (Time millisecondsSince: lastUpdate) >= msecs ifTrue:[ + bar value: count. + oldLabel = (newLabel := labelBlock value: each) ifFalse:[ + ProgressNotification signal: '' extra: (oldLabel := newLabel). + ]. + lastUpdate := Time millisecondClockValue. + ]. + ]]! Item was removed: - ----- Method: SequenceableCollection>>do:displayingProgress: (in category 'enumerating') ----- - do: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor cursorPoint - from: 0 to: self size - during: - [:bar | - self withIndexDo: - [:each :i | - bar value: i. - aBlock value: each]]!

1 0

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

31 Dec '09

Levente Uzonyi uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ul.362.mcz ==================== Summary ==================== Name: Kernel-ul.362 Author: ul Time: 31 December 2009, 7:04:23 am UUID: 96615f68-2456-7745-9ecb-335973913252 Ancestors: Kernel-ul.361 - speed up method trailer creation - speed up source fetching from source files =============== Diff against Kernel-ar.360 =============== Item was added: + ----- Method: CompiledMethod>>getSourceFromFileAt: (in category 'source code management') ----- + getSourceFromFileAt: sourcePointer + + | position index | + position := SourceFiles filePositionFromSourcePointer: sourcePointer. + position = 0 ifTrue: [ ^nil ]. + index := SourceFiles fileIndexFromSourcePointer: sourcePointer. + ^(RemoteString newFileNumber: index position: position) + text! Item was added: + ----- Method: CompiledMethodTrailer class>>trailerKindDecoders (in category 'generated') ----- + trailerKindDecoders + + ^#(#decodeNoTrailer #decodeClearedTrailer #decodeTempsNamesQCompress #decodeTempsNamesZip #decodeSourceBySelector #decodeSourceByStringIdentifier #decodeEmbeddedSourceQCompress #decodeEmbeddedSourceZip #decodeVarLengthSourcePointer #decodeExtendedKind #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeSourcePointer)! Item was changed: ----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') ----- getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." | trailer source | trailer := self trailer. trailer tempNames ifNotNil: [:namesString | "Magic sources -- decompile with temp names" ^ ((class decompilerClass new withTempNames: namesString) decompile: selector in: class method: self) decompileString]. trailer sourceCode ifNotNil: [:code | ^ code ]. trailer hasSourcePointer ifFalse: [ "No source pointer -- decompile without temp names" ^ (class decompilerClass new decompile: selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" + source := [self getSourceFromFileAt: trailer sourcePointer] - source := [self getSourceFromFile] on: Error "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." do: [ :ex | ex return: nil]. ^source ifNil: [ "Something really wrong -- decompile blind (no temps)" (class decompilerClass new decompile: selector in: class method: self) decompileString]! Item was changed: ----- Method: CompiledMethod>>getSourceFromFile (in category 'source code management') ----- getSourceFromFile + + ^self getSourceFromFileAt: self sourcePointer! - "Read the source code from file, determining source file index and - file position from the last 3 bytes of this method." - | position | - (position := self filePosition) = 0 ifTrue: [^ nil]. - ^ (RemoteString newFileNumber: self fileIndex position: position) - text! Item was changed: ----- Method: CompiledMethodTrailer>>method: (in category 'initialize-release') ----- method: aMethod + | flagByte index | - | flagByte | - data := size := nil. method := aMethod. + flagByte := method at: method size. - flagByte := method at: (method size). "trailer kind encoded in 6 high bits of last byte" + index := flagByte >> 2 + 1. + kind := self class trailerKinds at: index. - kind := self class trailerKinds at: 1+(flagByte>>2). "decode the trailer bytes" + self perform: (self class trailerKindDecoders at: index). - self perform: ('decode' , kind) asSymbol. "after decoding the trailer, size must be set" + self assert: size notNil - self assert: (size notNil). ! Item was changed: ----- Method: CompiledMethodTrailer class>>trailerKinds (in category 'as yet unclassified') ----- trailerKinds + " see class comment for description. If you change this method, evaluate this: + self generateTrailerKindDecoders" + + ^#( - " see class comment for description" - ^#( "000000" #NoTrailer "000001" #ClearedTrailer "000010" #TempsNamesQCompress "000011" #TempsNamesZip "000100" #SourceBySelector "000101" #SourceByStringIdentifier "000110" #EmbeddedSourceQCompress "000111" #EmbeddedSourceZip "001000" #VarLengthSourcePointer "001001" #ExtendedKind "001010" #Undefined "001011" #Undefined "001100" #Undefined "001101" #Undefined "001110" #Undefined "001111" #Undefined "010000" #Undefined "010001" #Undefined "010010" #Undefined "010011" #Undefined "010100" #Undefined "010101" #Undefined "010110" #Undefined "010111" #Undefined "011000" #Undefined "011001" #Undefined "011010" #Undefined "011011" #Undefined "011100" #Undefined "011101" #Undefined "011110" #Undefined "011111" #Undefined "100000" #Undefined "100001" #Undefined "100010" #Undefined "100011" #Undefined "100100" #Undefined "100101" #Undefined "100110" #Undefined "100111" #Undefined "101000" #Undefined "101001" #Undefined "101010" #Undefined "101011" #Undefined "101100" #Undefined "101101" #Undefined "101110" #Undefined "101111" #Undefined "110000" #Undefined "110001" #Undefined "110010" #Undefined "110011" #Undefined "110100" #Undefined "110101" #Undefined "110110" #Undefined "110111" #Undefined "111000" #Undefined "111001" #Undefined "111010" #Undefined "111011" #Undefined "111100" #Undefined "111101" #Undefined "111110" #Undefined "111111" #SourcePointer + )! - )! Item was changed: Object subclass: #CompiledMethodTrailer instanceVariableNames: 'data encodedData kind size method' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! + !CompiledMethodTrailer commentStamp: 'ul 12/31/2009 19:03' prior: 0! - !CompiledMethodTrailer commentStamp: 'Igor.Stasenko 12/13/2009 12:53' prior: 0! I am responsible for encoding and decoding various kinds of compiled method trailer data. I should not expose any binary data outside of myself, so all tools which working with compiled methods should ask me to encode the meta-data, they want to be added to the compiled method trailer, as well as retrieve it. To add a new kind of trailer, you should give it a proper name and define it in the #trailerKinds method at my class side. + Then you need to implement a corresponding #encode<your name> and #decode<your name> methods at instance side. Then add any public accessor methods, which will use a newly introduced trailer kind for communicating with outer layer(s). And finally evaluate: self generateTrailerKindDecoders. - Then you need to implement a corresponding #encode<your name> and #decode<your name> methods at instance side. Then add any public accessor methods, which will use a newly introduced trailer kind for communicating with outer layer(s). An encodeXXX methods should store result (byte array) into encodedData instance variable. A decodeXXX methods should read the data from compiled method instance, held by 'method' ivar, and always set 'size' ivar (denoting a total length of trailer in compiled method) and optionally 'data' ivar which should keep a decoded data, ready to be used by outer layer(s) using accessor method(s) you providing. The kind of compiled method trailer is determined by the last byte of compiled method. The byte format used is following: "2rkkkkkkdd" where 'k' bits stands for 'kind' , allowing totally 64 different kinds of method trailer and 'd' bits is data. Following is the list of currently defined trailer kinds: NoTrailer , k = 000000, dd unused method has no trailer, and total trailer size bytes is always 1 ClearedTrailer, k = 000001, method has cleared trailer (it was set to something else, but then cleared) dd+1 determines the number of bytes for size field, and size is a total length of trailer bytes So a total length of trailer is: 1 + (dd + 1) + size TempsNamesQCompress, k = 000010 the trailer contains a list of method temp names, compressed using qCompress: method. dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer. So a total length of trailer is: 1 + (dd + 1) + size TempsNamesZip, k = 000011 the trailer contains a list of method temp names, compressed using GZIP compression method. dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer So a total length of trailer is: 1 + (dd + 1) + size SourceBySelector, k = 000100 the trailer indicates , that method source is determined by a class + selector where it is installed to. Trailer size = 1. SourceByStringIdentifier, k = 000101 the trailer indicates , that method source is determined by a class + some ByteString identifier. dd+1 determines the number of bytes for size of ByteString identifier, and size is number of bytes of string. A total length of trailer is: 1 + (dd + 1) + size EmbeddedSourceQCompress, k = 000110 the trailer contains an utf-8 encoded method source code, compressed using qCompress method dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed source code A total length of trailer is: 1 + (dd + 1) + size EmbeddedSourceZip, k = 000111 the trailer contains an utf-8 encoded method source code, comressed using GZIP dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer A total length of trailer is: 1 + (dd + 1) + size VarLengthSourcePointer, k = 001000 the trailer is variable-length encoded source pointer. dd bits is unused. ExtendedKind, k = 001001 the next byte of trailer (one that prepends the last byte of compiled method) denotes an extended kind of trailer, allowing to use additional 256 kinds of encoding method's trailer in future. SourcePointer, k = 111111 the trailer is encoded source pointer. Total trailer size is 4-bytes (this kind of encoding is backwards compatible with most of existing compiled methods) ! Item was added: + ----- Method: CompiledMethodTrailer class>>generateTrailerKindDecoders (in category 'as yet unclassified') ----- + generateTrailerKindDecoders + + self class + compile: (String streamContents: [ :stream | + stream + nextPutAll: 'trailerKindDecoders'; cr; + cr; + tab; nextPut: $^; print: ( + self trailerKinds collect: [ :each | + ('decode', each) asSymbol ]) ]) + classified: 'generated' + !

1 0

NanoTraits in trunk
by Andreas Raab 31 Dec '09

31 Dec '09

Folks - As I'm sure you've noticed, I've pushed the NanoTraits updates. There is one oddity in the middle namely you'll get a merge request for ClassDescription caused by some MC issue earlier (for some reason, an ealier update didn't include the change to the class var). Choose to "keep" it and continue. Other than that everything should be in excellent shape after the updates. There should be no newly failing tests and no unexpected passes. If you have external packages that have traits dependencies of any sort, I'd be interested to find out if NanoTraits introduce any problems with your packages. If so, please report what kinds of problems you're seeing so that we can address them. Cheers, - Andreas

3 5

Re: [squeak-dev] The Trunk: Kernel-ar.350.mcz
by Igor Stasenko 31 Dec '09

31 Dec '09

+ ----- 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.! this should be fixed. A method which comes from trait should be always copied before installing into behavior. Otherwise, super sends won't work properly, as well as you may end up with a mess, where trait holding a reference to the non-existing behavior (added then removed) , because installing a method into method dict always changes its methodClass.

2 1

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

31 Dec '09

Andreas Raab uploaded a new version of TraitsTests to project The Trunk: http://source.squeak.org/trunk/TraitsTests-ar.1.mcz ==================== Summary ==================== Name: TraitsTests-ar.1 Author: ar Time: 31 December 2009, 3:57:32 am UUID: e4d14d09-2f43-1e44-b244-ed76a3641e1e Ancestors: Put traits tests back as separate package. ==================== Snapshot ==================== SystemOrganization addCategory: #'TraitsTests-Kernel'! TestResource subclass: #TraitsResource instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty' classVariableNames: 'SetUpCount' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitsResource class>>resetIfDirty (in category 'as yet unclassified') ----- resetIfDirty self current isDirty ifTrue: [self reset]! ----- Method: TraitsResource>>c1 (in category 'accessing') ----- c1 ^c1! ----- Method: TraitsResource>>c1: (in category 'accessing') ----- c1: anObject ^c1 := anObject! ----- Method: TraitsResource>>c2 (in category 'accessing') ----- c2 ^c2! ----- Method: TraitsResource>>c2: (in category 'accessing') ----- c2: anObject ^c2 := anObject! ----- Method: TraitsResource>>c3 (in category 'accessing') ----- c3 ^c3! ----- Method: TraitsResource>>c3: (in category 'accessing') ----- c3: anObject ^c3 := anObject! ----- Method: TraitsResource>>c4 (in category 'accessing') ----- c4 ^c4! ----- Method: TraitsResource>>c4: (in category 'accessing') ----- c4: anObject ^c4 := anObject! ----- Method: TraitsResource>>c5 (in category 'accessing') ----- c5 ^c5! ----- Method: TraitsResource>>c5: (in category 'accessing') ----- c5: anObject ^c5 := anObject! ----- Method: TraitsResource>>c6 (in category 'accessing') ----- c6 ^c6! ----- Method: TraitsResource>>c6: (in category 'accessing') ----- c6: anObject ^c6 := anObject! ----- Method: TraitsResource>>c7 (in category 'accessing') ----- c7 ^c7! ----- Method: TraitsResource>>c7: (in category 'accessing') ----- c7: anObject ^c7 := anObject! ----- Method: TraitsResource>>c8 (in category 'accessing') ----- c8 ^c8! ----- Method: TraitsResource>>c8: (in category 'accessing') ----- c8: anObject ^c8 := anObject! ----- Method: TraitsResource>>categoryName (in category 'as yet unclassified') ----- categoryName ^self class category! ----- Method: TraitsResource>>codeChangedEvent: (in category 'as yet unclassified') ----- codeChangedEvent: anEvent (anEvent isDoIt not and: [anEvent itemClass notNil] and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]) ifTrue: [self setDirty] ! ----- Method: TraitsResource>>createClassNamed:superclass:uses: (in category 'as yet unclassified') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsResource>>createTraitNamed:uses: (in category 'as yet unclassified') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsResource>>createdClassesAndTraits (in category 'as yet unclassified') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsResource>>isDirty (in category 'accessing') ----- isDirty ^dirty! ----- Method: TraitsResource>>setDirty (in category 'accessing') ----- setDirty dirty := true! ----- Method: TraitsResource>>setUp (in category 'as yet unclassified') ----- setUp "Please note, that most tests rely on this setup of traits and classes - and that especially the order of the definitions matters." "SetUpCount := SetUpCount + 1." dirty := false. SystemChangeNotifier uniqueInstance doSilently: [self t1: (self createTraitNamed: #T1 uses: { }). self t1 comment: 'I am the trait T1'. self t2: (self createTraitNamed: #T2 uses: { }). self t2 compile: 'm21 ^21' classified: #cat1. self t2 compile: 'm22 ^22' classified: #cat2. self t2 classSide compile: 'm2ClassSide: a ^a'. self t3: (self createTraitNamed: #T3 uses: { }). self t3 compile: 'm31 ^31' classified: #cat1. self t3 compile: 'm32 ^32' classified: #cat2. self t3 compile: 'm33 ^33' classified: #cat3. self t4: (self createTraitNamed: #T4 uses: { (self t1). (self t2) }). self t4 compile: 'm11 ^41' classified: #catX. "overrides T1>>m11" self t4 compile: 'm42 ^42' classified: #cat2. self t5: (self createTraitNamed: #T5 uses: self t1 + self t2). self t5 compile: 'm51 ^super foo' classified: #cat1. self t5 compile: 'm52 ^ self class bar' classified: #cat1. self t5 compile: 'm53 ^ self class bar' classified: #cat1. self t6: (self createTraitNamed: #T6 uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }). self c1: (self createClassNamed: #C1 superclass: Object uses: { }). self c1 compile: 'foo ^true' classified: #accessing. self t1 compile: 'm11 ^11' classified: #cat1. self t1 compile: 'm12 ^12' classified: #cat2. self t1 compile: 'm13 ^self m12' classified: #cat3. self c2: (self createClassNamed: #C2 superclass: self c1 uses: self t5 - { #m11 }). self c2 compile: 'foo ^false' classified: #private. self c2 compile: 'bar ^self foo' classified: #private. self setUpTrivialRequiresFixture. self setUpTwoLevelRequiresFixture. self setUpTranslatingRequiresFixture]. SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:! ----- Method: TraitsResource>>setUpTranslatingRequiresFixture (in category 'as yet unclassified') ----- setUpTranslatingRequiresFixture self c6: (self createClassNamed: #C6 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c6. self c6 superclass: nil. self c7: (self createClassNamed: #C7 superclass: self c6 uses: { }). self c8: (self createClassNamed: #C8 superclass: self c7 uses: { }). self c6 compile: 'foo ^self x' classified: #accessing. self c7 compile: 'foo ^3' classified: #accessing. self c7 compile: 'bar ^super foo' classified: #accessing. self c8 compile: 'bar ^self blah' classified: #accessing! ----- Method: TraitsResource>>setUpTrivialRequiresFixture (in category 'as yet unclassified') ----- setUpTrivialRequiresFixture self c3: (self createClassNamed: #C3 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c3. self c3 superclass: nil. self c3 compile: 'foo ^self bla' classified: #accessing! ----- Method: TraitsResource>>setUpTwoLevelRequiresFixture (in category 'as yet unclassified') ----- setUpTwoLevelRequiresFixture self c4: (self createClassNamed: #C4 superclass: ProtoObject uses: { }). ProtoObject removeSubclass: self c4. self c4 superclass: nil. self c5: (self createClassNamed: #C5 superclass: self c4 uses: { }). self c4 compile: 'foo ^self blew' classified: #accessing. self c5 compile: 'foo ^self blah' classified: #accessing! ----- Method: TraitsResource>>t1 (in category 'accessing') ----- t1 ^t1! ----- Method: TraitsResource>>t1: (in category 'accessing') ----- t1: anObject ^t1 := anObject! ----- Method: TraitsResource>>t2 (in category 'accessing') ----- t2 ^t2! ----- Method: TraitsResource>>t2: (in category 'accessing') ----- t2: anObject ^t2 := anObject! ----- Method: TraitsResource>>t3 (in category 'accessing') ----- t3 ^t3! ----- Method: TraitsResource>>t3: (in category 'accessing') ----- t3: anObject ^t3 := anObject! ----- Method: TraitsResource>>t4 (in category 'accessing') ----- t4 ^t4! ----- Method: TraitsResource>>t4: (in category 'accessing') ----- t4: anObject ^t4 := anObject! ----- Method: TraitsResource>>t5 (in category 'accessing') ----- t5 ^t5! ----- Method: TraitsResource>>t5: (in category 'accessing') ----- t5: anObject ^t5 := anObject! ----- Method: TraitsResource>>t6 (in category 'accessing') ----- t6 ^t6! ----- Method: TraitsResource>>t6: (in category 'accessing') ----- t6: anObject ^t6 := anObject! ----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') ----- tearDown | behaviorName | SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. self createdClassesAndTraits do: [:aClassOrTrait | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := self t1: (self t2: (self t3: (self t4: (self t5: (self t6: (self c1: (self c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))! TestCase subclass: #TraitsTestCase instanceVariableNames: 'createdClassesAndTraits' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! TraitsTestCase subclass: #ClassTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: ClassTraitTest>>testChanges (in category 'testing') ----- testChanges "Test the most important features to ensure that general functionality of class traits are working." "self run: #testChanges" | classTrait | classTrait := self t1 classTrait. classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'. "local selectors" self assert: (classTrait includesLocalSelector: #m1ClassSide). self deny: (classTrait includesLocalSelector: #otherSelector). "propagation" self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). self assert: (self c2 class methodDict includesKey: #m1ClassSide). self shouldnt: [self c2 m1ClassSide] raise: Error. self assert: self c2 m1ClassSide = 17. "category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = 'mycategory'. "conflicts" self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. self assert: (self c2 class methodDict includesKey: #m1ClassSide). self deny: (self c2 class includesLocalSelector: #m1ClassSide). self should: [self c2 m1ClassSide] raise: Error. "conflict category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = #mycategory! ----- Method: ClassTraitTest>>testConflictsAliasesAndExclusions (in category 'testing') ----- testConflictsAliasesAndExclusions "conflict" self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. self assert: (self c2 class >> #m2ClassSide:) isConflict. "exclusion and alias" self assert: self t5 classSide traitComposition asString = 'T1 classTrait + T2 classTrait'. self t5 classSide uses: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } + self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } - { #m2ClassSide: }. self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. self deny: (self c2 class >> #m2ClassSide:) isConflict. self assert: (self c2 m2ClassSideAlias1: 13) = 99. self assert: (self c2 m2ClassSideAlias2: 13) = 13! ----- Method: ClassTraitTest>>testInitialization (in category 'testing') ----- testInitialization "self run: #testInitialization" | classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassTrait. self assert: self t1 classTrait == classTrait. self assert: classTrait isClassTrait. self assert: classTrait classSide == classTrait. self deny: classTrait isBaseTrait. self assert: classTrait baseTrait == self t1. "assert classtrait methods are propagated to users when setting traitComposition" self assert: self t4 hasClassTrait. self assert: self t5 hasClassTrait. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:). self assert: (self c2 m2ClassSide: 17) = 17! ----- Method: ClassTraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t2 classSide users size = 3. self assert: (self t2 classSide users includesAllOf: { (self t4 classTrait). (self t5 classTrait). (self t6 classTrait) }). self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t1 + self t5. self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 uses: self t2 asTraitComposition. self assert: self t5 classSide users isEmpty! TraitsTestCase subclass: #PureBehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: PureBehaviorTest>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19. self deny: (self c2 >> #m52) == (self t5 >> #m52). "no sharing!!" ! ----- Method: PureBehaviorTest>>testClassesWithTraits (in category 'testing-applying trait composition') ----- testClassesWithTraits "self debug: #testClassesWithTraits" self assert: (self c1 methodDict includesKey: #foo). self assert: (self c2 methodDict includesKey: #bar). self assert: (self c2 methodDict includesKey: #m51). self assert: (self c2 methodDict includesKey: #m12). self assert: (self c2 methodDict includesKey: #m13). self assert: (self c2 methodDict includesKey: #m21). self assert: (self c2 methodDict includesKey: #m22). self deny: self c1 class hasTraitComposition. self assert: self c2 class hasTraitComposition. self assert: (self c2 class traitComposition size = 1). self assert: (self c2 class includesTrait: self t5 classTrait)! ----- Method: PureBehaviorTest>>testIsAliasSelector (in category 'testing') ----- testIsAliasSelector self deny: (self t1 isAliasSelector: #m11). self deny: (self t1 isAliasSelector: #foo). "directly" self assert: (self t6 isAliasSelector: #m22Alias). self deny: (self t6 isAliasSelector: #m22). "indirectly" self c1 uses: self t6. self assert: (self c1 isAliasSelector: #m22Alias). self deny: (self c1 isAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testIsLocalAliasSelector (in category 'testing') ----- testIsLocalAliasSelector self deny: (self t1 isLocalAliasSelector: #m11). self deny: (self t1 isLocalAliasSelector: #foo). "directly" self assert: (self t6 isLocalAliasSelector: #m22Alias). self deny: (self t6 isLocalAliasSelector: #m22). "indirectly" self c1 uses: self t6 asTraitComposition. self deny: (self c1 isLocalAliasSelector: #m22Alias). self deny: (self c1 isLocalAliasSelector: #m22)! ----- Method: PureBehaviorTest>>testLocalSelectors (in category 'testing') ----- testLocalSelectors "self run: #testLocalSelectors" self assert: self t3 localSelectors size = 3. self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )). self assert: (self t3 includesLocalSelector: #m32). self deny: (self t3 includesLocalSelector: #inexistantSelector). self assert: self t5 localSelectors size = 3. self assert: (self t5 localSelectors includes: #m51). self assert: (self t5 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self t5 removeSelector: #m51. self deny: (self t3 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self assert: self t5 localSelectors size = 2. self t5 compile: 'm52 ^self'. self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). "test that propagated methods do not get in as local methods" self t2 compile: 'local2 ^self'. self deny: (self t5 includesLocalSelector: #local2). self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). self assert: self c2 localSelectors size = 2. self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))! ----- Method: PureBehaviorTest>>testMethodCategoryReorganization (in category 'testing') ----- testMethodCategoryReorganization "self run: #testMethodCategory" self t1 compile: 'm1' classified: 'category1'. self assert: (self t5 organization categoryOfElement: #m1) = #category1. self assert: (self c2 organization categoryOfElement: #m1) = #category1. self t1 organization classify: #m1 under: #category2 suppressIfDefault: true. self assert: (self t5 organization categoryOfElement: #m1) = #category2. self assert: (self c2 organization categoryOfElement: #m1) = #category2! ----- Method: PureBehaviorTest>>testOwnMethodsTakePrecedenceOverTraitsMethods (in category 'testing-applying trait composition') ----- testOwnMethodsTakePrecedenceOverTraitsMethods "First create a trait with no subtraits and then add subtrait t1 which implements m11 as well." | trait | trait := self createTraitNamed: #TraitsTestTrait uses: { }. trait compile: 'm11 ^999'. self assert: trait methodDict size = 1. self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self createTraitNamed: #TraitsTestTrait uses: self t1. self assert: trait methodDict size = 3. self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )). self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self assert: (trait methodDict at: #m12) decompileString = 'm12 ^ 12'! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraits (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraits | aC2 | aC2 := self c2 new. self assert: self c2 methodDict size = 9. self t1 compile: 'zork ^false'. self assert: self c2 methodDict size = 10. self deny: aC2 zork. self t1 removeSelector: #m12. self assert: self c2 methodDict size = 9. self should: [aC2 m12] raise: MessageNotUnderstood. self assert: aC2 m21 = 21. self t2 compile: 'm21 ^99'. self assert: aC2 m21 = 99! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethods (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethods | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t6) new. self assert: anObject m22Alias = 22. "test update alias method" self t2 compile: 'm22 ^17'. self assert: anObject m22Alias = 17. "removing original method should also remove alias method" self t2 removeSelector: #m22. self should: [anObject m22Alias] raise: MessageNotUnderstood! ----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded "Assert that alias method is updated although the original method is excluded from this user." | anObject | anObject := (self createClassNamed: #TraitsTestAliasTestClass superclass: Object uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new. self assert: anObject aliasM11 = 11. self deny: (anObject class methodDict includesKey: #m11). self t1 compile: 'm11 ^17'. self assert: anObject aliasM11 = 17! ----- Method: PureBehaviorTest>>testPropagationWhenTraitCompositionModifications (in category 'testing-applying trait composition') ----- testPropagationWhenTraitCompositionModifications "Test that the propagation mechanism works when setting new traitCompositions." self assert: self c2 methodDict size = 9. "2 + (3+(3+2))-1" "removing methods" self createTraitNamed: #T5 uses: self t1 + self t2 - { #m21. #m22 }. self assert: self c2 methodDict size = 7. "adding methods" self createTraitNamed: #T2 uses: self t3. self assert: self c2 methodDict size = 10. self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))! ----- Method: PureBehaviorTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! ----- Method: PureBehaviorTest>>testSuperSends (in category 'testing-applying trait composition') ----- testSuperSends | aC2 | aC2 := self c2 new. self assert: aC2 m51. self deny: aC2 foo. self deny: aC2 bar! ----- Method: PureBehaviorTest>>testTraitCompositionModifications (in category 'testing-applying trait composition') ----- testTraitCompositionModifications self assert: self t6 methodDict size = 6. self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'. self t6 uses: self t2 asTraitComposition. self assert: self t6 methodDict size = 2. self deny: (self t6 methodDict includesKey: #m22Alias). self t6 uses: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } + self t2. self assert: self t6 methodDict size = 4. self assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )). self assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'! ----- Method: PureBehaviorTest>>testTraitCompositionWithCycles (in category 'testing-applying trait composition') ----- testTraitCompositionWithCycles self should: [self t1 uses: self t1 asTraitComposition] raise: Error. self t2 uses: self t3 asTraitComposition. self should: [self t3 uses: self t5 asTraitComposition] raise: Error! ----- Method: PureBehaviorTest>>testUpdateWhenLocalMethodRemoved (in category 'testing-applying trait composition') ----- testUpdateWhenLocalMethodRemoved | aC2 | aC2 := self c2 new. self t5 compile: 'foo ^123'. self deny: aC2 foo. self c2 removeSelector: #foo. self assert: aC2 foo = 123! ----- Method: PureBehaviorTest>>traitOrClassOfSelector (in category 'testing') ----- traitOrClassOfSelector "self run: #traitOrClassOfSelector" "locally defined in trait or class" self assert: (self t1 >> #m12) originalTraitOrClass = self t1. self assert: (self c1 >> #foo) originalTraitOrClass = self c1. "not locally defined - simple" self assert: (self t4 >> #m21) originalTraitOrClass = self t2. self assert: (self c2 >> #m51) originalTraitOrClass = self t5. "not locally defined - into nested traits" self assert: (self c2 >> #m22) originalTraitOrClass = self t2. "not locally defined - aliases" self assert: (self t6 >> #m22Alias) originalTraitOrClass = self t2. "class side" self assert: (self t2 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide. self assert: (self t6 classSide >> #m2ClassSide:) originalTraitOrClass = self t2 classSide! TraitsTestCase subclass: #TraitCompositionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitCompositionTest>>testAliasCompositions (in category 'testing-basic') ----- testAliasCompositions "unary" self shouldnt: [self t2 uses: self t1 @ { (#aliasM11 -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias: -> #m11) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#alias:x:y: -> #m11) }] raise: TraitCompositionException. "binary" self t1 compile: '= anObject'. self shouldnt: [self t2 uses: self t1 @ { (#equals: -> #=) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#% -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals -> #=) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#equals:x: -> #=) }] raise: TraitCompositionException. "keyword" self t1 compile: 'x: a y: b z: c'. self should: [self t2 uses: self t1 @ { (#'==' -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x: -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 uses: self t1 @ { (#x:y: -> #x:y:z:) }] raise: TraitCompositionException. self shouldnt: [self t2 uses: self t1 @ { (#myX:y:z: -> #x:y:z:) }] raise: TraitCompositionException. "alias same as selector" self should: [self t2 uses: self t1 @ { (#m11 -> #m11) }] raise: TraitCompositionException. "same alias name used twice" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias -> #m12) }] raise: TraitCompositionException. "aliasing an alias" self should: [self t2 uses: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testClassMethodsTakePrecedenceOverTraitsMethods (in category 'testing-enquiries') ----- testClassMethodsTakePrecedenceOverTraitsMethods | keys | keys := Set new. self t4 methodDict bindingsDo: [:each | keys add: each key]. self assert: keys size = 6. self assert: (keys includesAllOf: #( #m12 #m13 #m13 #m21 #m22 #m11 #m42 )). self assert: (self t4 methodDict at: #m11) decompileString = 'm11 ^ 41'! ----- Method: TraitCompositionTest>>testCompositionFromArray (in category 'testing-basic') ----- testCompositionFromArray | composition | composition := TraitComposition withAll: { (self t1) }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: composition traits size = 1. composition := TraitComposition withAll: { (self t1). self t2 }. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: composition traits size = 2! ----- Method: TraitCompositionTest>>testEmptyTrait (in category 'testing-basic') ----- testEmptyTrait | composition | composition := TraitComposition withAll: {}. self assert: (composition isKindOf: TraitComposition). " self assert: composition transformations isEmpty. " self assert: composition traits isEmpty! ----- Method: TraitCompositionTest>>testInvalidComposition (in category 'testing-basic') ----- testInvalidComposition self shouldnt: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self shouldnt: [self t1 - { #a } - { #b }] raise: TraitCompositionException. self shouldnt: [self t1 + self t2 - { #a } - { #b }] raise: TraitCompositionException. self should: [(self t1 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [self t1 + self t1] raise: TraitCompositionException. self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#b -> #a) }] raise: TraitCompositionException! ----- Method: TraitCompositionTest>>testPrinting (in category 'testing-basic') ----- testPrinting | composition1 composition2 | composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } + self t3 - { #d. #e } + self t4) @ { (#x -> #a). (#y -> #b) }. composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } + self t3 - { #d. #e } + self t2 - { #b. #c }. self assertPrints: composition1 printString like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'. self assertPrints: composition2 printString like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'! ----- Method: TraitCompositionTest>>testProvidedMethodBindingsWithConflicts (in category 'testing-enquiries') ----- testProvidedMethodBindingsWithConflicts | traitWithConflict methodDict | traitWithConflict := self createTraitNamed: #TraitsTestTraitWithConflict uses: self t1 + self t4. methodDict := traitWithConflict methodDict. self assert: methodDict size = 6. self assert: (methodDict keys includesAllOf: #( #m11 #m12 #m13 #m21 #m22 #m42 )). self assert: (methodDict at: #m11) decompileString = 'm11 ^ self traitConflict'! ----- Method: TraitCompositionTest>>testSum (in category 'testing-basic') ----- testSum | composition | composition := self t1 + self t2 + self t3. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3! ----- Method: TraitCompositionTest>>testSumWithParenthesis (in category 'testing-basic') ----- testSumWithParenthesis | composition | composition := self t1 + (self t2 + self t3). self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3. self assert: composition size = 3! TraitsTestCase subclass: #TraitFileOutTest instanceVariableNames: 'ca cb ta tb tc td' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitFileOutTest>>categoryName (in category 'running') ----- categoryName ^'TraitsTests-FileOut'! ----- Method: TraitFileOutTest>>fileIn: (in category 'testing') ----- fileIn: fileName | prior file result | prior := ClassDescription traitImpl. [ ClassDescription traitImpl: Trait. file := FileStream readOnlyFileNamed: fileName. result := file fileIn ] ensure: [ file ifNotNil:[file close]. ClassDescription traitImpl: prior. ]. ^result! ----- Method: TraitFileOutTest>>setUp (in category 'running') ----- setUp super setUp. SystemOrganization addCategory: self categoryName. td := self createTraitNamed: #TD uses: {}. td compile: 'd' classified: #cat1. tc := self createTraitNamed: #TC uses: td. tc compile: 'c' classified: #cat1. tb := self createTraitNamed: #TB uses: td. tb compile: 'b' classified: #cat1. ta := self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}. ta compile: 'a' classified: #cat1. ca := self createClassNamed: #CA superclass: Object uses: {}. ca compile: 'ca' classified: #cat1. cb := self createClassNamed: #CB superclass: ca uses: ta. cb compile: 'cb' classified: #cat1. "make the class of cb also use tc:" cb class uses: ta classTrait + tc instanceVariableNames: ''.! ----- Method: TraitFileOutTest>>tearDown (in category 'running') ----- tearDown | dir | dir := FileDirectory default. self createdClassesAndTraits, self resourceClassesAndTraits do: [:each | dir deleteFileNamed: each asString , '.st' ifAbsent: []]. dir deleteFileNamed: self categoryName , '.st' ifAbsent: []. SystemOrganization removeSystemCategory: self categoryName. super tearDown! ----- Method: TraitFileOutTest>>testFileOutCategory (in category 'testing') ----- testFileOutCategory "File out whole system category, delete all classes and traits and then file them in again." "self run: #testFileOutCategory" | | SystemOrganization fileOutCategory: self categoryName. SystemOrganization removeSystemCategory: self categoryName. self deny: (Smalltalk keys includesAnyOf: #(CA CB TA TB TC TD)). self fileIn: self categoryName , '.st'.. self assert: (Smalltalk keys includesAllOf: #(CA CB TA TB TC TD)). ta := Smalltalk at: #TA. self assert: (ta isKindOf: Trait). self assert: ta traitComposition asString = 'TB + TC @ {#cc->#c} - {#c}'. self assert: (ta methodDict keys includesAllOf: #(a b cc)). cb := Smalltalk at: #CB. self assert: (cb isKindOf: Class). self assert: cb traitComposition asString = 'TA'. self assert: (cb methodDict keys includesAllOf: #(cb a b cc)). "test classSide traitComposition of CB" self assert: cb classSide traitComposition asString = 'TA classTrait + TC'. self assert: (cb classSide methodDict keys includesAllOf: #(d c)) ! ----- Method: TraitFileOutTest>>testFileOutTrait (in category 'testing') ----- testFileOutTrait "fileOut trait T6, remove it from system and then file it in again" "self run: #testFileOutTrait" | fileName | self t6 compile: 'localMethod: argument ^argument'. self t6 classSide compile: 'localClassSideMethod: argument ^argument'. self t6 fileOut. fileName := self t6 asString , '.st'. self resourceClassesAndTraits remove: self t6. self t6 removeFromSystem. self fileIn: fileName. self assert: (Smalltalk includesKey: #T6). TraitsResource current t6: (Smalltalk at: #T6). self resourceClassesAndTraits add: self t6. self assert: (self t6 isKindOf: Trait). self assert: self t6 traitComposition asString = 'T1 + T2 @ {#m22Alias->#m22}'. self assert: (self t6 methodDict keys includesAllOf: #( #localMethod: #m11 #m12 #m13 #m21 #m22 #m22Alias )). self assert: self t6 classSide methodDict size = 2. self assert: (self t6 classSide methodDict keys includesAllOf: #(#localClassSideMethod: #m2ClassSide: ))! ----- Method: TraitFileOutTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated." "self run: #testRemovingMethods" "Classes" self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12). "Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12! TraitsTestCase subclass: #TraitMethodDescriptionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitMethodDescriptionTest>>testArgumentNames (in category 'running') ----- testArgumentNames self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2')! ----- Method: TraitMethodDescriptionTest>>testCategories (in category 'running') ----- testCategories self assert: (self t4 organization categoryOfElement: #m21) = #cat1. self assert: (self t4 organization categoryOfElement: #m22) = #cat2. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t4 organization categoryOfElement: #m12) = #cat2. self assert: (self t4 organization categoryOfElement: #m13) = #cat3. self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2. self t2 organization classify: #m22 under: #catX. self assert: (self t4 organization categoryOfElement: #m22) = #catX. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX. self t6 organization classify: #m22 under: #catY. self t6 organization classify: #m22Alias under: #catY. self t2 organization classify: #m22 under: #catZ. "XXX: The following test is commented out for now. The policy is to *always* reclassify the method if the base method is reclassified. That results from the requirement that the base construction should always be repeatable (in fact, one could argue that reclassification of methods from traits is invalid without some explicit transformation)." false ifTrue:[ self assert: (self t6 organization categoryOfElement: #m22) = #catY. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY. ]. self t1 compile: 'mA' classified: #catA. self assert: (self t4 organization categoryOfElement: #mA) = #catA. self t1 organization classify: #mA under: #cat1. self assert: (self t4 organization categories includes: #catA) not! ----- Method: TraitMethodDescriptionTest>>testConflictMethodCreation (in category 'running') ----- testConflictMethodCreation "Generate conflicting methods between t1 and t2 and check the resulting method in Trait t5 (or c2). Also test selectors like foo:x (without space) or selectors with CRs." "unary" self t2 compile: 'm12 ^false'. self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12'). self should: [self c2 new m12] raise: Error. "binary" self t1 compile: '@ myArgument ^true'. self t2 compile: '@myArgument ^false'. self assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ arg1'). self should: [self c2 new @ 17] raise: Error. "keyword" self t1 compile: 'zork: myArgument ^true'. self t2 compile: 'zork: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork:myArgument ^true'. self t2 compile: 'zork:myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: arg1'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: anObject zork2: anotherObject ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self should: [self c2 new zork1: 1 zork2: 2] raise: Error! ----- Method: TraitMethodDescriptionTest>>testConflictingCategories (in category 'running') ----- testConflictingCategories | t7 t8 | self t2 compile: 'm11' classified: #catY. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #cat1" t7 := self createTraitNamed: #T7 uses: self t1 + self t2. self assert: (t7 organization categoryOfElement: #m11) = #'conflict methods'. "was: ClassOrganizer ambiguous" self t1 removeSelector: #m11. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #catY. self assert: (t7 organization categoryOfElement: #m11) = #catY. self deny: (t7 organization categories includes: #'conflict methods' "was: ClassOrganizer ambiguous"). self t1 compile: 'm11' classified: #cat1. t8 := self createTraitNamed: #T8 uses: self t1 + self t2. t8 organization classify: #m11 under: #cat1. self t1 organization classify: #m11 under: #catZ. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catY" self assert: (t8 organization categoryOfElement: #m11) = #'conflict methods'. "was: #catZ"! TraitsTestCase subclass: #TraitSystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitSystemTest>>testAllClassesAndTraits (in category 'testing') ----- testAllClassesAndTraits "self debug: #testAllClassesAndTraits" | trait | trait := self t1. self assert: (Smalltalk allClassesAndTraits includes: trait). self deny: (Smalltalk allClasses includes: trait). ! ----- Method: TraitSystemTest>>testAllImplementedMessagesWithout (in category 'testing') ----- testAllImplementedMessagesWithout "self debug: #testAllImplementedMessagesWithout" self t6 compile: 'das2qwdqwd'. self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd). self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).! ----- Method: TraitSystemTest>>testAllSentMessages (in category 'testing') ----- testAllSentMessages "self debug: #testAllSentMessages" self t1 compile: 'foo 1 dasoia'. self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol). self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).! TraitsTestCase subclass: #TraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'TraitsTests-Kernel'! ----- Method: TraitTest>>testAddAndRemoveMethodsFromSubtraits (in category 'testing') ----- testAddAndRemoveMethodsFromSubtraits | aC2 | aC2 := self c2 new. self assert: aC2 m51. self t5 removeSelector: #m51. self should: [aC2 m51] raise: MessageNotUnderstood. self t1 compile: 'foo ^true'. self deny: aC2 foo. self t1 compile: 'm51 ^self'. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51 == aC2! ----- Method: TraitTest>>testAddAndRemoveMethodsInClassOrTrait (in category 'testing') ----- testAddAndRemoveMethodsInClassOrTrait | aC2 | aC2 := self c2 new. self assert: aC2 m51. self c2 compile: 'm51 ^123'. self assert: aC2 m51 = 123. self c2 removeSelector: #m51. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51. self t4 removeSelector: #m11. self assert: (self t4 methodDict includesKey: #m11)! ----- Method: TraitTest>>testAllClassVarNames (in category 'testing') ----- testAllClassVarNames self assert: self t1 allClassVarNames isEmpty! ----- Method: TraitTest>>testCompositionCopy (in category 'testing') ----- testCompositionCopy | t6compositionCopyFirst c2compositionCopy | self assert: (self t1 + self t2) allTraits = (self t1 + self t2) copyTraitExpression allTraits. self assert: (self t1 classTrait + self t2 classTrait) allTraits = (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits. self assert: self t6 traitComposition allTraits = self t6 traitComposition copyTraitExpression allTraits. self assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }. false ifTrue:[ "make no undue sharing happens of exclusions and aliases after an expression copy" t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. t6compositionCopyFirst transformations at: 1 put: #m22Alias -> #m33. self assert: self t6 traitComposition transformations second aliases first value = #m22. c2compositionCopy := self c2 traitComposition copyTraitExpression. c2compositionCopy transformations first exclusions at: 1 put: #m4. self c2 traitComposition transformations first exclusions = #(#m11 ) ].! ----- Method: TraitTest>>testExplicitRequirement (in category 'testing') ----- testExplicitRequirement "self run: #testExplicitRequirement" self t1 compile: 'm self explicitRequirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testMarkerMethods (in category 'testing') ----- testMarkerMethods "self debug: #testMarkerMethods" self t1 compile: 'm1 self foo bar'. self assert: (self t1 >> #m1) markerOrNil isNil. self t1 compile: 'm2 self requirement'. self assert: (self t1 >> #m2) markerOrNil == #requirement. self t1 compile: 'm3 ^self requirement'. self assert: (self t1 >> #m3) markerOrNil == #requirement.! ----- Method: TraitTest>>testPrinting (in category 'testing') ----- testPrinting self assertPrints: self t6 definitionST80 like: 'Trait named: #T6 uses: T1 + T2 @ {#m22Alias->#m22} category: ''TraitsTests-Kernel'''! ----- Method: TraitTest>>testPrintingClassSide (in category 'testing') ----- testPrintingClassSide "self run: #testPrintingClassSide" self assertPrints: self t6 classSide definitionST80 like: 'T6 classTrait uses: T1 classTrait + T2 classTrait'! ----- Method: TraitTest>>testRemoveFromSystem (in category 'testing') ----- testRemoveFromSystem self t4 removeFromSystem. self deny: (Smalltalk includesKey: #T4). self assert: self t4 name = 'AnObsoleteT4'. self assert: self t4 methodDict isEmpty. self deny: (self t1 users includes: self t4)! ----- Method: TraitTest>>testRequirement (in category 'testing') ----- testRequirement "self run: #testRequirement" self t1 compile: 'm self requirement'. self t2 compile: 'm ^true'. self deny: (self t4 >> #m) == (self t2 >> #m). "no sharing!!" self assert: self c2 new m. self t2 removeSelector: #m. self deny: (self t5 >> #m) == (self t1 >> #m). "no sharing!!" self should: [self c2 new m] raise: Error! ----- Method: TraitTest>>testTraitFromPattern (in category 'testing') ----- testTraitFromPattern | newTrait | newTrait := self createTraitNamed: #TTraitTestBaseTrait uses: {}. self assert: (Utilities classFromPattern: 'TTraitTestBaseT' withCaption: '') = newTrait.! ----- Method: TraitTest>>testTraitMethodClass (in category 'testing') ----- testTraitMethodClass "Tests that the #methodClass of a trait method isn't screwed up" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: baseTrait. methodA := classA compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: baseTrait. methodB := classB compiledMethodAt: #traitMethod. self assert: traitMethod methodClass == baseTrait. self assert: methodA methodClass == classA. self assert: methodB methodClass == classB.! ----- Method: TraitTest>>testTraitMethodSelector (in category 'testing') ----- testTraitMethodSelector "Tests that the #selector of a trait method isn't screwed up when aliasing traits" | baseTrait classA methodA classB methodB traitMethod | baseTrait := self createTraitNamed: #TraitTestBaseTrait uses:{}. baseTrait compileSilently: 'traitMethod' classified: 'tests'. traitMethod := baseTrait compiledMethodAt: #traitMethod. self assert: traitMethod selector == #traitMethod. classA := self createClassNamed: #TraitTestMethodClassA superclass: Object uses: {baseTrait @ {#methodA -> #traitMethod}}. methodA := classA compiledMethodAt: #methodA. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. classB := self createClassNamed: #TraitTestMethodClassB superclass: Object uses: {baseTrait @ {#methodB -> #traitMethod}}. methodB := classB compiledMethodAt: #methodB. self assert: traitMethod selector == #traitMethod. self assert: methodA selector == #methodA. self assert: methodB selector == #methodB.! ----- Method: TraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t1 users size = 3. self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }). self assert: self t3 users isEmpty. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t1 + self t5. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 uses: self t2 asTraitComposition. self assert: self t5 users isEmpty! ----- Method: TraitsTestCase class>>resources (in category 'as yet unclassified') ----- resources ^{TraitsResource}! ----- Method: TraitsTestCase>>assertPrints:like: (in category 'utility') ----- assertPrints: aString like: anotherString self assert: (aString copyWithout: $ ) = (anotherString copyWithout: $ )! ----- Method: TraitsTestCase>>c1 (in category 'accessing') ----- c1 ^TraitsResource current c1! ----- Method: TraitsTestCase>>c2 (in category 'accessing') ----- c2 ^TraitsResource current c2! ----- Method: TraitsTestCase>>c3 (in category 'accessing') ----- c3 ^TraitsResource current c3! ----- Method: TraitsTestCase>>c4 (in category 'accessing') ----- c4 ^TraitsResource current c4! ----- Method: TraitsTestCase>>c5 (in category 'accessing') ----- c5 ^TraitsResource current c5! ----- Method: TraitsTestCase>>c6 (in category 'accessing') ----- c6 ^TraitsResource current c6! ----- Method: TraitsTestCase>>c7 (in category 'accessing') ----- c7 ^TraitsResource current c7! ----- Method: TraitsTestCase>>c8 (in category 'accessing') ----- c8 ^TraitsResource current c8! ----- Method: TraitsTestCase>>categoryName (in category 'running') ----- categoryName ^self class category! ----- Method: TraitsTestCase>>createClassNamed:superclass:uses: (in category 'utility') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class! ----- Method: TraitsTestCase>>createTraitNamed:uses: (in category 'utility') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName env: Smalltalk. self createdClassesAndTraits add: trait. ^trait! ----- Method: TraitsTestCase>>createdClassesAndTraits (in category 'utility') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits! ----- Method: TraitsTestCase>>resourceClassesAndTraits (in category 'utility') ----- resourceClassesAndTraits ^TraitsResource current createdClassesAndTraits! ----- Method: TraitsTestCase>>t1 (in category 'accessing') ----- t1 ^TraitsResource current t1! ----- Method: TraitsTestCase>>t2 (in category 'accessing') ----- t2 ^TraitsResource current t2! ----- Method: TraitsTestCase>>t3 (in category 'accessing') ----- t3 ^TraitsResource current t3! ----- Method: TraitsTestCase>>t4 (in category 'accessing') ----- t4 ^TraitsResource current t4! ----- Method: TraitsTestCase>>t5 (in category 'accessing') ----- t5 ^TraitsResource current t5! ----- Method: TraitsTestCase>>t6 (in category 'accessing') ----- t6 ^TraitsResource current t6! ----- Method: TraitsTestCase>>tearDown (in category 'running') ----- tearDown | behaviorName | TraitsResource resetIfDirty. self createdClassesAndTraits do: [:aClassOrTrait | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := nil! ----- Method: TraitsTestCase>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass" "Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass." | aC2 newSuperclass | aC2 := self c2 new. "C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51). "change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #TraitsTestX superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category. self assert: self c2 superclass == newSuperclass. newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51). self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19. "no sharing!!" self deny: (self c2 >> #m52) == (self t5 >> #m52).!

1 0

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

31 Dec '09

Andreas Raab uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-ar.127.mcz ==================== Summary ==================== Name: KernelTests-ar.127 Author: ar Time: 31 December 2009, 3:53:50 am UUID: 0ab6e7cb-7cfb-854f-995b-1c09fd3d5348 Ancestors: KernelTests-nice.126 Correct a newly failing test which didn't account for eventual trait / classtrait instances. =============== Diff against KernelTests-nice.126 =============== Item was changed: ----- Method: BasicBehaviorClassMetaclassTest>>testClassDescriptionAllSubInstances (in category 'testing') ----- testClassDescriptionAllSubInstances "self run: #testClassDescriptionAllSubInstances" | cdNo clsNo metaclsNo | cdNo := ClassDescription allSubInstances size. clsNo := Class allSubInstances size . metaclsNo := Metaclass allSubInstances size. + "When traits are present, discount all traits if necessary" + Smalltalk at: #Trait ifPresent:[:aClass| + (aClass inheritsFrom: ClassDescription) ifTrue:[ + cdNo := cdNo - Trait instanceCount - ClassTrait instanceCount. + ]. + ]. - self assert: cdNo = (clsNo + metaclsNo). !

1 0

The Trunk: Traits-ar.271.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.271.mcz ==================== Summary ==================== Name: Traits-ar.271 Author: ar Time: 31 December 2009, 3:45:08 am UUID: c7f78cfa-a551-ee4d-a4a5-f4f6da2bbad6 Ancestors: Traits-ar.270 Fix a few issues where we should operate on the elements of the trait transform instead of the transform itself. =============== Diff against Traits-ar.270 =============== Item was changed: ----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') ----- installTraitsFrom: aTraitComposition + "Install the traits from the given composition. This method implements + the core composition method - all others are just optimizations for + particular cases. Consequently, the optimized versions can always fall + back to this method when things get too hairy." - "Install the traits from the given composition" | allTraits methods oldMethod removals oldCategories | (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 do:[:tc| tc removeTraitUser: self]. - self traitComposition removeTraitUser: self. self traitComposition: aTraitComposition. + aTraitComposition do:[:tc| tc addTraitUser: self]. - 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].! Item was changed: ----- Method: ClassDescription>>includesTrait: (in category '*Traits-NanoKernel') ----- includesTrait: aTrait + ^self traitComposition anySatisfy:[:each| each includesTrait: aTrait]! - ^self traitComposition includesTrait: aTrait! Item was removed: - ----- Method: TraitComposition>>includesTrait: (in category 'testing') ----- - includesTrait: aTrait - ^self anySatisfy:[:each| each includesTrait: aTrait]! Item was removed: - ----- Method: TraitComposition>>addTraitUser: (in category 'accessing') ----- - addTraitUser: aUser - self do:[:each| each addTraitUser: aUser]! Item was removed: - ----- Method: TraitComposition>>removeTraitUser: (in category 'accessing') ----- - removeTraitUser: aUser - self do:[:each| each removeTraitUser: aUser]!

1 0

The Trunk: Kernel-ar.360.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.360.mcz ==================== Summary ==================== Name: Kernel-ar.360 Author: ar Time: 31 December 2009, 3:42:08 am UUID: 64a98687-3714-f34f-abf5-0eef057762aa Ancestors: Kernel-ar.359 Fix small typo in obsoletion - removeTraitUser: should be sent to the elements of the composition. =============== Diff against Kernel-ar.359 =============== Item was changed: ----- Method: ClassDescription>>obsolete (in category 'initialize-release') ----- obsolete "Make the receiver obsolete." self hasTraitComposition ifTrue: [ + self traitComposition do: [:each | - self traitComposition traits do: [:each | each removeTraitUser: self]]. superclass removeSubclass: self. self organization: nil. super obsolete.!

1 0

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

31 Dec '09

Andreas Raab uploaded a new version of ScriptLoader to project The Trunk: http://source.squeak.org/trunk/ScriptLoader-ar.329.mcz ==================== Summary ==================== Name: ScriptLoader-ar.329 Author: ar Time: 31 December 2009, 3:16:19 am UUID: 07e096f6-df09-e247-82f2-49ba916ff768 Ancestors: ScriptLoader-nice.328 Final trait cleanup touches: Avoid Undeclared references. =============== Diff against ScriptLoader-nice.328 =============== Item was changed: ----- Method: ScriptLoader>>flushCaches (in category 'cleaning') ----- flushCaches MCFileBasedRepository flushAllCaches. MCDefinition clearInstances. Smalltalk garbageCollect. "Initialization required for tests: strange why this is not a teardwon method" + Smalltalk at: #SendCaches ifPresent:[:aClass| aClass initializeAllInstances].! - SendCaches initializeAllInstances.!

1 0

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

31 Dec '09

Andreas Raab uploaded a new version of ReleaseBuilder to project The Trunk: http://source.squeak.org/trunk/ReleaseBuilder-ar.43.mcz ==================== Summary ==================== Name: ReleaseBuilder-ar.43 Author: ar Time: 31 December 2009, 3:14:53 am UUID: a6e0fb19-bc46-834f-abea-23cfbc54f216 Ancestors: ReleaseBuilder-nice.42 Final trait cleanup touches: Avoid Undeclared references. =============== Diff against ReleaseBuilder-nice.42 =============== Item was changed: ----- Method: ReleaseBuilderFor3dot10>>flushCaches (in category 'managing updates') ----- flushCaches MCFileBasedRepository flushAllCaches. MCDefinition clearInstances. Smalltalk garbageCollect. "Initialization required for tests: strange why this is not a teardwon method" + Smalltalk at: #SendCaches ifPresent:[:aClass| aClass initializeAllInstances].! - SendCaches initializeAllInstances.! Item was removed: - ----- Method: ReleaseBuilderFor3dot11>>prepareToUnloadTraits (in category 'unloadPackages') ----- - prepareToUnloadTraits - "ReleaseBuilderFor3dot11 new prepareToUnloadTraits" - SystemChangeNotifier uniqueInstance - noMoreNotificationsFor: ProvidedSelectors current; - noMoreNotificationsFor: RequiredSelectors current; - noMoreNotificationsFor: LocalSends current. - self unloadTraitsStubOutAcessors. - - [ClassDescription subclass: #Metaclass - instanceVariableNames: 'thisClass' - classVariableNames: ' ' - poolDictionaries: ' ' - category: 'Kernel-Classes'. - ClassDescription subclass: #Class - instanceVariableNames: 'subclasses name classPool sharedPools environment category' - classVariableNames: ' ' - poolDictionaries: ' ' - category: 'Kernel-Classes'. - ] on: Warning do: [:warning | warning resume]. - - Smalltalk allTraits do: [:trait | trait removeFromSystem. trait := nil]. - "Recompile all methods that were part of a trait" - SystemNavigation default allBehaviorsDo: [:class | class selectorsAndMethodsDo: [:sel :method | class ~~ method methodClass ifTrue: [class recompile: sel]. method := nil]. class := nil]. - "Remove references to traits from various places in the code" - self unloadTraits!

1 0

Jump to page: