The Trunk: KernelTests-eem.377.mcz

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

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

Name: KernelTests-eem.377
Author: eem
Time: 11 March 2020, 6:50:54.691022 pm
UUID: ffe697e5-da6e-4c3c-98ac-fd190f0169eb
Ancestors: KernelTests-eem.376

WriteBarrierTest
Add a test for become.
Add a test for updating multiple inst vars in a single method.
Extend several of the tests to include additional testing of being able to separate retryModificationNoresume from resume

=============== Diff against KernelTests-eem.376 ===============

Item was added:
+ ----- Method: WriteBarrierTest>>testAttemptToMutateLiterals (in category 'tests - object') -----
+ testAttemptToMutateLiterals
+ | guineaPigs |
+ guineaPigs := {#[1 2 3] . #(1 2 3) }.
+ guineaPigs do:
+ [ :guineaPig |
+ self should: [guineaPig at: 1 put: 4]
+ raise: ModificationForbidden].
+
+ self should: [guineaPigs first become: guineaPigs second ]
+ raise: ModificationForbidden.
+
+ self should: [ByteString adoptInstance: guineaPigs first]
+ raise: ModificationForbidden.
+
+ self should: [WeakArray adoptInstance: guineaPigs last]
+ raise: ModificationForbidden!

Item was added:
+ ----- Method: WriteBarrierTest>>testBecomeReadOnly (in category 'tests - object') -----
+ testBecomeReadOnly
+ | readOnlyArrays readOnlyByteArrays |
+ readOnlyArrays := (1 to: 3) collect: [:n| (0 to: n) asArray beReadOnlyObject; yourself].
+ "N.B. if the targets are read-only this fails, which is correct for elementsForwardIdentityTo: since copyHash is implicitly true;
+ we need to write a test for a putative elementsForwardIdentityNoCopyHashTo:"
+ readOnlyByteArrays := (1 to: 3) collect: [:n| (0 to: n) asByteArray" beReadOnlyObject; yourself"].
+ self should: [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
+ raise: ModificationForbidden.
+ [readOnlyArrays elementsForwardIdentityTo: readOnlyByteArrays]
+ on: ModificationForbidden
+ do: [:ex|
+ false
+ ifTrue: "This fails, but should succeed.  I *think* it's to do with catching signals when resignalling"
+ [(ex mirror detect: [:element| element isReadOnlyObject] ifNone: []) ifNotNil:
+ [:readOnlyObj| readOnlyObj beWritableObject]]
+ ifFalse:
+ [ex mirror do: [:element| element beWritableObject]].
+ ex retryModification].
+ self assert: (readOnlyArrays allSatisfy: [:array| array class == ByteArray])!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ guineaPig byteAt: 1 put: 13  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig byteAt: 1 put: 13  ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: 13.
+ self assert: guineaPig isReadOnlyObject!
- self assert: guineaPig first equals: 12!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
+ raise: ModificationForbidden.
+
+ [ guineaPig doubleAt: 1 put: (2 raisedTo: 64) asFloat ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: (2 raisedTo: 64) asFloat.
+ self assert: guineaPig isReadOnlyObject!
- self assert: guineaPig first equals: (2 raisedTo: 65) asFloat!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig floatAt: 1 put: 2.0  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig floatAt: 1 put: 2.0 ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig first equals: 2.0.
+ self assert: guineaPig isReadOnlyObject!
- self assert: guineaPig first equals: 1.0!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+
+ self
+ should: [ guineaPig at: 1 put: $g  ]
+ raise: ModificationForbidden.
+
+ [ guineaPig at: 1 put: $g ]
+ on: ModificationForbidden
+ do: [:modification |
+ self assert: modification fieldIndex equals: 1.
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume ].
+
+ self assert: guineaPig first equals: $g.
+ self assert: guineaPig isReadOnlyObject!
- self assert: guineaPig first equals: $h!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig beReadOnlyObject.
+ self
+ should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ raise: ModificationForbidden.
+
+ [ WriteBarrierAnotherStub adoptInstance: guineaPig ]
+ on: ModificationForbidden
+ do: [ :modification |
+ modification object beWritableObject.
+ modification retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume].
+
+ self assert: guineaPig class equals: WriteBarrierAnotherStub.
+ self assert: guineaPig isReadOnlyObject!
- self assert: guineaPig class equals: WriteBarrierAnotherStub!

Item was changed:
  ----- 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.
+ self deny: guineaPig isReadOnlyObject.
+
+ 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 retryModificationNoResume.
+ modification object beReadOnlyObject.
+ modification resume ].
+
+ self assert: guineaPig first equals: #test.
+ self assert: guineaPig isReadOnlyObject
+ !
- self assert: guineaPig first equals: #test!

Item was added:
+ ----- Method: WriteBarrierTest>>testRetryingPointInstVarModification (in category 'tests - object') -----
+ testRetryingPointInstVarModification
+ | guineaPig labRat |
+ guineaPig := 1@2.
+ labRat := guineaPig copy bitShiftPoint: 3.
+ guineaPig beReadOnlyObject.
+
+ [ guineaPig bitShiftPoint: 3 ]
+ on: ModificationForbidden
+ do: [:err |
+ guineaPig beWritableObject.
+ err retryModification ].
+
+ self assert: guineaPig equals: labRat.
+ self deny: guineaPig isReadOnlyObject.
+
+ guineaPig bitShiftPoint: -3; beReadOnlyObject.
+ self assert: guineaPig equals: 1@2.
+
+ [ guineaPig bitShiftPoint: 3 ]
+ on: ModificationForbidden
+ do: [:err |
+ guineaPig beWritableObject.
+ err retryModificationNoResume.
+ guineaPig beReadOnlyObject.
+ err resume ].
+
+ self assert: guineaPig equals: labRat.
+ self assert: guineaPig isReadOnlyObject!