The Trunk: KernelTests-eem.376.mcz

Eliot Miranda uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-eem.376.mcz

==================== Summary ====================

Name: KernelTests-eem.376
Author: eem
Time: 11 March 2020, 1:15:31.498035 pm
UUID: 250e07ee-5f92-4553-b861-7a5a66dbf08d
Ancestors: KernelTests-nice.375

Add the tests in WriteBarrierTests to accompany Kernel-eem.1317

=============== Diff against KernelTests-nice.375 ===============

Item was changed:
  SystemOrganization addCategory: #'KernelTests-Classes'!
  SystemOrganization addCategory: #'KernelTests-Methods'!
  SystemOrganization addCategory: #'KernelTests-Numbers'!
  SystemOrganization addCategory: #'KernelTests-Objects'!
  SystemOrganization addCategory: #'KernelTests-Processes'!
+ SystemOrganization addCategory: #'KernelTests-WriteBarrier'!

Item was added:
+ Object subclass: #WriteBarrierAnotherStub
+ instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!

Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var1 (in category 'accessing') -----
+ var1
+ ^ var1!

Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var10 (in category 'accessing') -----
+ var10
+ ^ var10!

Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var10: (in category 'accessing') -----
+ var10: anObject
+ var10 := anObject!

Item was added:
+ ----- Method: WriteBarrierAnotherStub>>var1: (in category 'accessing') -----
+ var1: anObject
+ var1 := anObject!

Item was added:
+ Object subclass: #WriteBarrierStub
+ instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!

Item was added:
+ ----- Method: WriteBarrierStub>>var1 (in category 'accessing') -----
+ var1
+ ^ var1!

Item was added:
+ ----- Method: WriteBarrierStub>>var10 (in category 'accessing') -----
+ var10
+ ^ var10!

Item was added:
+ ----- Method: WriteBarrierStub>>var10: (in category 'accessing') -----
+ var10: anObject
+ var10 := anObject!

Item was added:
+ ----- Method: WriteBarrierStub>>var1: (in category 'accessing') -----
+ var1: anObject
+ var1 := anObject!

Item was added:
+ TestCase subclass: #WriteBarrierTest
+ instanceVariableNames: ''
+ classVariableNames: 'ContextInstance'
+ poolDictionaries: ''
+ category: 'KernelTests-WriteBarrier'!
+
+ !WriteBarrierTest commentStamp: '' prior: 0!
+ My tests ensure the ReadOnly property of objects work properly.
+
+ #testMutateIVObject is a good start to understand what is going on.
+
+ The VM needs to be compiled with -DIMMUTABILTY= true for those tests to work.!

Item was added:
+ ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') -----
+ initialize
+
+ ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()!

Item was added:
+ ----- Method: WriteBarrierTest>>alwaysReadOnlyObjects (in category 'guinea pigs') -----
+ alwaysReadOnlyObjects
+ "Immediates are always immutable"
+ ^ { 1 }!

Item was added:
+ ----- Method: WriteBarrierTest>>alwaysWritableObjects (in category 'guinea pigs') -----
+ alwaysWritableObjects
+ "Objects that currently can't be immutable"
+ ^ { ContextInstance .
+ Processor .
+ Processor activeProcess }!

Item was added:
+ ----- Method: WriteBarrierTest>>expectedFailures (in category 'expected failures') -----
+ expectedFailures
+ Smalltalk supportsReadOnlyObjects ifFalse:
+ [^self class testSelectors].
+ ^#( testMutateByteArrayUsingDoubleAtPut testMutateByteArrayUsingFloatAtPut ),
+  ((Smalltalk classNamed: #MirrorPrimitives)
+ ifNil: [#(testBasicProxyReadOnly testBasicProxyWritable testSetIsReadOnlySuccessProxy)]
+ ifNotNil: [#()])!

Item was added:
+ ----- Method: WriteBarrierTest>>maybeReadOnlyObjects (in category 'guinea pigs') -----
+ maybeReadOnlyObjects
+ "ByteObject, Variable object, fixed sized object"
+ ^ { { 1 . 2 . 3 } asByteArray . { 1 . 2 . 3 } . (MessageSend receiver: 1 selector: #+ argument: 2) }!

Item was added:
+ ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') -----
+ testBasicProxyReadOnly
+ self alwaysReadOnlyObjects do: [ :each |
+ self assert: (MirrorPrimitives isObjectReadOnly: each) equals: true ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testBasicProxyWritable (in category 'tests - proxy') -----
+ testBasicProxyWritable
+ self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
+ self assert: (MirrorPrimitives isObjectReadOnly: each) equals: false ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testBasicReadOnly (in category 'tests - object') -----
+ testBasicReadOnly
+ self alwaysReadOnlyObjects do: [ :each |
+ self assert: each isReadOnlyObject equals: true ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testBasicWritable (in category 'tests - object') -----
+ testBasicWritable
+ self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
+ self assert: each isReadOnlyObject equals: false ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingByteAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingByteAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig byteAt: 1 put: 12  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 12 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: 12!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingDoubleAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingDoubleAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 8.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
+ raise: ModificationForbidden.
+
+ [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: (2 raisedTo: 65) asFloat!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteArrayUsingFloatAtPut (in category 'tests - object') -----
+ testMutateByteArrayUsingFloatAtPut
+ | guineaPig |
+ guineaPig := ByteArray new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig floatAt: 1 put: 1.0  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig floatAt: 1 put: 1.0 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: 1.0!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteStringyUsingAtPut (in category 'tests - object') -----
+ testMutateByteStringyUsingAtPut
+ | guineaPig |
+ guineaPig := ByteString new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $h  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $h ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: $h!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteStringyUsingByteAtPut (in category 'tests - object') -----
+ testMutateByteStringyUsingByteAtPut
+ | guineaPig |
+ guineaPig := ByteString new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig byteAt: 1 put: 100  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 100 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first asciiValue equals: 100!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateByteSymbolUsingPrivateAtPut (in category 'tests - object') -----
+ testMutateByteSymbolUsingPrivateAtPut
+ | guineaPig |
+ [guineaPig := #hello.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: ((guineaPig class includesSelector: #pvtAt:put:)
+ ifTrue: [[ guineaPig perform: #pvtAt:put: with: 1 with: $q ]] "Squeak refuses to compile non-self sends of pvt* selectors."
+ ifFalse: [[ guineaPig privateAt: 1 put: $q ]])
+ raise: ModificationForbidden ]
+ ensure:
+ [ guineaPig beWritableObject ].
+
+ self assert: guineaPig first equals: $h!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateIVObject (in category 'tests - object') -----
+ testMutateIVObject
+ | guineaPig |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+ [ guineaPig receiver: 1 ]
+ on: ModificationForbidden
+ do: [ :modification | "Surely a NoModification error" ].
+ guineaPig
+ beWritableObject;
+ selector: #+;
+ beReadOnlyObject.
+ [ guineaPig arguments: #(2) ]
+ on: ModificationForbidden
+ do: [  :modification |"Surely a NoModification error" ].
+ self assert: guineaPig receiver isNil.
+ self assert: guineaPig arguments isNil.
+ self assert: guineaPig selector == #+.!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectClass (in category 'tests - object') -----
+ testMutateObjectClass
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
+ raise: ModificationForbidden.
+
+ [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectClassViaAdoption (in category 'tests - object') -----
+ testMutateObjectClassViaAdoption
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ raise: ModificationForbidden.
+
+ [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectFirstInstVarWithManyVars (in category 'tests - object') -----
+ testMutateObjectFirstInstVarWithManyVars
+ | guineaPig failure |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig var1: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure fieldIndex equals: 1!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarShouldCatchRightFailure (in category 'tests - object') -----
+ testMutateObjectInstVarShouldCatchRightFailure
+ | guineaPig failure |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig receiver: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure object == guineaPig.
+ self assert: failure newValue equals: #test.
+ self assert: failure fieldIndex equals: 1.!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingAtPut
+ | guineaPig |
+ guineaPig := Array new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: #test  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: #test!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingBasicAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingBasicAtPut
+ | guineaPig |
+ guineaPig := Array new: 5.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig basicAt: 1 put: #test  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: #test!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingInstVarAtPut (in category 'tests - object') -----
+ testMutateObjectInstVarUsingInstVarAtPut
+ | guineaPig |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig instVarAt: 1 put: #test  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig instVarAt: 1 put: #test ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig var1 equals: #test!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateObjectLastInstVarWithManyVars (in category 'tests - object') -----
+ testMutateObjectLastInstVarWithManyVars
+ | guineaPig failure |
+ guineaPig := WriteBarrierStub new.
+ guineaPig beReadOnlyObject.
+ failure := [ guineaPig var10: #test ] on: ModificationForbidden do: [:err | err].
+
+ self assert: failure fieldIndex equals: 10!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateVariableObject (in category 'tests - object') -----
+ testMutateVariableObject
+ | guineaPigs |
+ guineaPigs := {#[1 2 3] . #(1 2 3) }.
+ guineaPigs do: [ :guineaPig |
+ guineaPig beReadOnlyObject.
+ [guineaPig at: 1 put: 4]
+ on: ModificationForbidden  
+ do: [ "Surely a NoModification error" ].
+ guineaPig
+ beWritableObject;
+ at: 2 put:  5;
+ beReadOnlyObject.
+ [guineaPig at: 3 put: 6]
+ on: ModificationForbidden  
+ do: [ "Surely a NoModification error" ].
+ self assert: guineaPig first = 1.
+ self assert: guineaPig second = 5.
+ self assert: guineaPig third = 3 ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateWideStringUsingAtPut (in category 'tests - object') -----
+ testMutateWideStringUsingAtPut
+ | guineaPig |
+ guineaPig := 'hello' asWideString.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $q  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $q ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first equals: $q!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateWideStringUsingWordAtPut (in category 'tests - object') -----
+ testMutateWideStringUsingWordAtPut
+ | guineaPig |
+ guineaPig := 'hello' asWideString.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig wordAt: 1 put: 65536  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig wordAt: 1 put: 65536 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModification ].
+
+ self assert: guineaPig first asciiValue equals: 65536!

Item was added:
+ ----- Method: WriteBarrierTest>>testMutateWideSymbolUsingPrivateAtPut (in category 'tests - object') -----
+ testMutateWideSymbolUsingPrivateAtPut
+ | guineaPig |
+ [ guineaPig := ('hello', (Character codePoint: 8002) asString) asSymbol.
+ guineaPig beReadOnlyObject.
+
+ self
+ should: ((guineaPig class includesSelector: #pvtAt:put:)
+ ifTrue: [[ guineaPig perform: #pvtAt:put: with: 1 with: $A ]] "Squeak refuses to compile non-self sends of pvt* selectors."
+ ifFalse: [[ guineaPig privateAt: 1 put: $A ]])
+ raise: ModificationForbidden ]
+ ensure: [ guineaPig beWritableObject ].
+
+ self assert: guineaPig first  equals: $h!

Item was added:
+ ----- Method: WriteBarrierTest>>testObject:initialState:tuples: (in category 'tests - helper') -----
+ testObject: object initialState: initialState tuples: tuples
+ self
+ testObject: object
+ initialState: initialState
+ tuples: tuples
+ setReadOnlyBlock: [ :value | object setIsReadOnlyObject: value ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testObject:initialState:tuples:setReadOnlyBlock: (in category 'tests - helper') -----
+ testObject: object initialState: initialState tuples: tuples setReadOnlyBlock: setImmutabilityBlock
+ self assert: object isReadOnlyObject equals: initialState.
+ tuples do: [ :tuple |
+ | stateToSet expectedResult expectedNewState |
+ stateToSet := tuple first.
+ expectedResult := tuple second.
+ expectedNewState := tuple last.
+ [self assert: (setImmutabilityBlock value: stateToSet) equals: expectedResult ]
+ on: ((Smalltalk classNamed: #PrimitiveFailed) ifNil: [Error])
+ do: [ self assert: (self alwaysReadOnlyObjects , self alwaysWritableObjects includes: object) ].
+ self assert: object isReadOnlyObject equals: expectedNewState ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testProxyObject:initialState:tuples: (in category 'tests - helper') -----
+ testProxyObject: object initialState: initialState tuples: tuples
+ self
+ testObject: object
+ initialState: initialState
+ tuples: tuples
+ setReadOnlyBlock: [ :value |
+ MirrorPrimitives makeObject: object readOnly: value ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testRetryingInstVarModification (in category 'tests - object') -----
+ testRetryingInstVarModification
+ | guineaPig |
+ guineaPig := MessageSend new.
+ guineaPig beReadOnlyObject.
+
+ [ guineaPig receiver: 1 ] on: ModificationForbidden do: [:err |
+ guineaPig beWritableObject.
+ err retryModification ].
+
+ self assert: guineaPig receiver equals: 1!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailure (in category 'tests - object') -----
+ testSetIsReadOnlyFailure
+ self alwaysWritableObjects do: [ :each |
+ self
+ testObject: each
+ initialState: false
+ tuples: #( (true false false) (false false false) ) ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailureProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlyFailureProxy
+ self alwaysWritableObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: false
+ tuples: #( (true false false) (false false false) ) ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediate (in category 'tests - object') -----
+ testSetIsReadOnlyImmediate
+ self alwaysReadOnlyObjects do: [ :each |
+ self
+ testObject: each
+ initialState: true
+ tuples: #( (true true true) (false true true) ) ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediateProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlyImmediateProxy
+ self alwaysReadOnlyObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: true
+ tuples: #( (true true true) (false true true) ) ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccess (in category 'tests - object') -----
+ testSetIsReadOnlySuccess
+ self maybeReadOnlyObjects do: [ :each |
+ self
+ testObject: each
+ initialState: false
+ tuples: #( (true false true) (false true false) ) ]!

Item was added:
+ ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccessProxy (in category 'tests - proxy') -----
+ testSetIsReadOnlySuccessProxy
+ self maybeReadOnlyObjects do: [ :each |
+ self
+ testProxyObject: each
+ initialState: false
+ tuples: #( (true false true) (false true false) ) ]!