The Inbox: KernelTests-ct.395.mcz

A new version of KernelTests was added to project The Inbox:
http://source.squeak.org/inbox/KernelTests-ct.395.mcz

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

Name: KernelTests-ct.395
Author: ct
Time: 20 March 2021, 7:17:49.390742 pm
UUID: 76e4d450-32dd-d24c-8aad-68ad212ec955
Ancestors: KernelTests-mt.394, KernelTests-ct.375

Tests simulation of #perform:... primitives 83, 84, and 100. Complements Kernel-ct.1367. Reuploaded to add another fixture for the mirror primitive variant of primitive 100. Corrected order of assertion arguments.

Replaces KernelTests-ct.38{2,3}, which can be moved into the treated inbox.

Depends indeed not only on KernelTests-mt.394 but also on KernelTests-ct.375, it would be nice if we could get the latter merged soon, this has already been causing too many merge conflicts in the past. :-)

=============== Diff against KernelTests-mt.394 ===============

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'!
- SystemOrganization addCategory: #'KernelTests-Models'!

Item was changed:
  ----- Method: AllocationTest>>testOutOfMemorySignal (in category 'tests') -----
  testOutOfMemorySignal
+        "Ensure that OutOfMemory is signaled eventually"
-        "Ensure that OutOfMemory is signaled eventually. Restrain the available memory first to not stress the machine too much."
-       
         | sz |
         self setFreeSpaceLimitOf: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
                                                                                                                 ifTrue: [4]
                                                                                                                 ifFalse: [1.5])
                 around:
                         [sz := 512*1024*1024. "work around the 1GB alloc bug"
+                         self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].
+
+        "Call me when this test fails, I want your machine."
+        "Current (2017) Spur VMs fail new: & basicNew: with #'bad argument' if given other than a non-negative SmallInteger."
+        sz := 1024*1024*1024*1024.
+        self should: [Array new: sz]
+                raise: OutOfMemory, Error
+                withExceptionDo:
+                        [:ex|
+                         ex class == Error ifTrue:
+                                [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument']]]!
-                         self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].!

Item was removed:
- ----- Method: AllocationTest>>testOutOfMemorySignalExtreme (in category 'tests') -----
- testOutOfMemorySignalExtreme
-        "Try to allocate a ridiculous amount of memory and check whether the expected error is signaled. Call Eliot when this test fails, he want your machine. :-)
-       
-        Note that current (2017) Spur VMs fail in #new: and #basicNew: with #'bad argument' if given other than a non-negative SmallInteger.
-       
-        Also note that this test can be quite stressful to your machine depending on how your operating system allocates the required memory behind the curtains. Better not triggering some robot fetching a tape from somewhere..."
-       
-        | sz |
-        sz := 1024*1024*1024*1024. "= 1 TiB"
-        self should: [Array new: sz]
-                raise: OutOfMemory, Error
-                withExceptionDo:
-                        [:ex|
-                         ex class == Error ifTrue:
-                                [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument']]]!

Item was removed:
- ----- Method: BlockClosureTest>>return: (in category 'private') -----
- return: something
-
-        ^ something!

Item was removed:
- ----- Method: BlockClosureTest>>testMoreThanOnce (in category 'tests - evaluating') -----
- testMoreThanOnce
-        "Make sure that we can use once more than once"
-        | moreThanOnce |
-        moreThanOnce := (1 to: 3) collect: [:e | [String new] once -> [Array new] once].
-        self assert: (moreThanOnce allSatisfy: [:each | each key isString]).
-        self assert: (moreThanOnce allSatisfy: [:each | each value isArray]).
-        self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
-        self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).!

Item was removed:
- ----- Method: BlockClosureTest>>testMoreThanOnceForEqualBlocks (in category 'tests - evaluating') -----
- testMoreThanOnceForEqualBlocks
-        "Make sure that we can use once more than once"
-        | moreThanOnce |
-        moreThanOnce := (1 to: 3) collect: [:e | [Object new] once -> [Object new] once].
-        self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
-        self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).
-        self assert: (moreThanOnce noneSatisfy: [:each | each key == each value]).!

Item was changed:
  ----- Method: BlockClosureTest>>testRunSimulated (in category 'tests') -----
  testRunSimulated
+        self assert: Rectangle equals: (Context runSimulated: aBlockClosure asContext) class!
-        self assert: Rectangle equals:
-                (Context runSimulated: aBlockClosure asContext) class.
-        self assert: 42 equals:
-                (Context runSimulated: [self return: 42]).
-        self
-                should: [Context runSimulated: [self halt]]
-                raise: Halt.!

Item was removed:
- ----- Method: BlockClosureTest>>testRunSimulatedContextAtEachStep (in category 'tests') -----
- testRunSimulatedContextAtEachStep
-
-        | context |
-        context := aBlockClosure asContext.
-        self assert: Rectangle equals: (thisContext
-                runSimulated: context
-                contextAtEachStep: [:ctxt | self assert:
-                        [ctxt == context or: [ctxt hasSender: context]]]) class.!

Item was changed:
  ----- Method: BlockClosureTest>>testSetUp (in category 'tests') -----
  testSetUp
         "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
         self deny: aBlockClosure isContext.
         self assert: aBlockClosure isClosure.
         self assert: aBlockClosure home = homeOfABlockClosure.
         self assert: aBlockClosure receiver = self.
+        self assert: aBlockClosure method isCompiledMethod!
-        self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
-                ifTrue: [aBlockClosure method isCompiledBlock]
-                ifFalse: [aBlockClosure method isCompiledMethod])!

Item was changed:
  ----- Method: BlockClosureTest>>testTallyInstructions (in category 'tests') -----
  testTallyInstructions
+        self assert: (Context tallyInstructions: aBlockClosure asContext) size = 15!
-        self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
-                        ifTrue: [14]
-                        ifFalse: [15])
-                equals: (Context tallyInstructions: aBlockClosure asContext) size!

Item was changed:
  ----- Method: ClassTest>>testChangeClassOf (in category 'tests') -----
  testChangeClassOf
         "Exercise primitiveChangeClass (primitive 115) for a common use case. This should pass
         for any Squeak image format (but failed for image format 68002 prior to VM fix)"
 
+        self shouldnt: [Inspector new primitiveChangeClassTo: CompiledMethodInspector new] raise: Error!
-        self shouldnt: [Exception new primitiveChangeClassTo: Error new] raise: Error!

Item was changed:
  ----- Method: CompiledMethodTest>>testClosureSize (in category 'tests - closures') -----
  testClosureSize
+        self
+                assert: ((self class >> #withClosure) embeddedBlockClosures at: 1) size
+                        equals: 2;
+                assert: ((self class >> #withClosureNoNLR) embeddedBlockClosures at: 1) size
+                        equals: 2!
-        | compiledMethod expectedSize |
-        compiledMethod := (self class >> #withClosure).
-        expectedSize := compiledMethod bytecodeSetName
-                caseOf: {
-                        ['SistaV1'] -> [3].
-                        ['V3PlusClosures'] -> [2]}.
-        self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.
-        compiledMethod := (self class >> #withClosureNoNLR).
-        expectedSize := compiledMethod bytecodeSetName
-                caseOf: {
-                        ['SistaV1'] -> [3].
-                        ['V3PlusClosures'] -> [2]}.
-        self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.!

Item was added:
+ TestCase subclass: #ContextTest
+        instanceVariableNames: 'aCompiledMethod aReceiver aSender aContext'
+        classVariableNames: ''
+        poolDictionaries: ''
+        category: 'KernelTests-Methods'!
+
+ !ContextTest commentStamp: 'ct 1/27/2020 13:03' prior: 0!
+ I am an SUnit Test of Context. See also BlockClosureTest.
+ See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak see http://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ and http://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecodes/.  (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
+ My fixtures are:
+ aReceiver                     - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
+ aSender                       - just some arbitrary object, thisContext
+ aCompiledMethod       - just some arbitrary method, "Rectangle rightCenter".
+ aContext                      - just some arbitray context ... 
+
+ !

Item was added:
+ ----- Method: ContextTest>>privRestartTest (in category 'private') -----
+ privRestartTest
+        "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
+        |a firstTimeThrough |
+        firstTimeThrough := true.
+        a := 10.
+       
+        self assert: 30 equals: [|b|
+                self assert: 10 = a .
+                self assert: nil == b.
+                b := a + 20.
+                firstTimeThrough ifTrue: [
+                        firstTimeThrough := false.
+                        thisContext restart.].
+                b] value
+ !

Item was added:
+ ----- Method: ContextTest>>setUp (in category 'running') -----
+ setUp
+        super setUp.
+        aCompiledMethod := Rectangle methodDict at: #rightCenter.
+        aReceiver := 100@100 corner: 200@200.
+        aSender := thisContext.
+        aContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !

Item was added:
+ ----- Method: ContextTest>>testActivateReturnValue (in category 'tests') -----
+ testActivateReturnValue
+        self assert:  (aSender activateReturn: aContext value: #()) isContext.
+        self assert:  ((aSender activateReturn: aContext value: #()) receiver = aContext).!

Item was added:
+ ----- Method: ContextTest>>testCopyStack (in category 'tests') -----
+ testCopyStack
+        self assert: aContext copyStack printString = aContext printString.!

Item was added:
+ ----- Method: ContextTest>>testFindContextSuchThat (in category 'tests') -----
+ testFindContextSuchThat
+        self assert: (aContext findContextSuchThat: [:each| true]) printString = aContext printString.
+        self assert: (aContext hasContext: aContext). !

Item was added:
+ ----- Method: ContextTest>>testMethodContext (in category 'tests') -----
+ testMethodContext
+        self assert: aContext home notNil.
+        self assert: aContext receiver notNil.
+        self assert: aContext method isCompiledMethod.!

Item was added:
+ ----- Method: ContextTest>>testMethodIsBottomContext (in category 'tests') -----
+ testMethodIsBottomContext
+        self assert: aContext bottomContext = aSender.
+        self assert: aContext secondFromBottom = aContext.!

Item was added:
+ ----- Method: ContextTest>>testPrimitive100 (in category 'tests') -----
+ testPrimitive100
+
+        {
+                {#isNil. {}. Object}. "valid 0-arg message"
+                {#=. {true}. UndefinedObject}. "valid unary message"
+                {#ifNil:ifNotNil:. {[2]. [:x | x]}. Object}. "valid binary message"
+                {{}. #=. {true}. SequenceableCollection}. "mirror primitive"
+                {#isNil}. "missing arguments"
+                {#isNil. 'not an array'}. "invalid arguments"
+                {#isNil. {}}. "missing lookupClass"
+                {#isNil. {'excess arg'}. Object}. "too many arguments"
+                {#=. {}. UndefinedObject}. "missing argument"
+                {#isNil. {}. Boolean}. "lookupClass not in inheritance chain"
+        } do: [:args |
+                self
+                        assert: (nil tryPrimitive: 100 withArgs: args)
+                        equals: (Context runSimulated: [nil tryPrimitive: 100 withArgs: args])].!

Item was added:
+ ----- Method: ContextTest>>testPrimitive83 (in category 'tests') -----
+ testPrimitive83
+
+        {
+                {#isNil}. "valid 0-arg message"
+                {#=. true}. "valid unary message"
+                {#ifNil:ifNotNil:. [2]. [:x | x]}. "valid binary message"
+                {#isNil. 'excess arg'}. "too many arguments"
+                {#=}. "missing argument"
+        } do: [:args |
+                self
+                        assert: (nil tryPrimitive: 83 withArgs: args)
+                        equals: (Context runSimulated: [nil tryPrimitive: 83 withArgs: args])].!

Item was added:
+ ----- Method: ContextTest>>testPrimitive84 (in category 'tests') -----
+ testPrimitive84
+
+        {
+                {#isNil. {}}. "valid 0-arg message"
+                {#=. {true}}. "valid unary message"
+                {#ifNil:ifNotNil:. {[2]. [:x | x]}}. "valid binary message"
+                {#isNil}. "missing arguments"
+                {#isNil. 'not an array'}. "invalid arguments"
+                {#isNil. {'excess arg'}}. "too many arguments"
+                {#=. {}}. "missing argument"
+        } do: [:args |
+                self
+                        assert: (nil tryPrimitive: 84 withArgs: args)
+                        equals: (Context runSimulated: [nil tryPrimitive: 84 withArgs: args])].!

Item was added:
+ ----- Method: ContextTest>>testRestart (in category 'tests') -----
+ testRestart
+        self should: [self privRestartTest] notTakeMoreThan: 0.1 second!

Item was added:
+ ----- Method: ContextTest>>testReturn (in category 'tests') -----
+ testReturn
+        "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
+        aContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
+        self assert: (aContext return: 5) = 5!

Item was added:
+ ----- Method: ContextTest>>testSetUp (in category 'tests') -----
+ testSetUp
+        "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
+        self assert: aContext isContext.
+        self deny: aContext isExecutingBlock.
+        self deny: aContext isClosure.
+        self deny: aContext isDead.
+        "self assert: aMethodContext home = aReceiver."
+        "self assert: aMethodContext blockHome = aReceiver."
+        self assert: aContext receiver = aReceiver.
+        self assert: aContext method isCompiledMethod.
+        self assert: aContext method = aCompiledMethod.
+        self assert: aContext methodNode selector = #rightCenter.
+        self assert: (aContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
+        self assert: aContext client printString = 'ContextTest>>#testSetUp'.
+ !

Item was removed:
- ----- Method: FloatTest class>>testClassConstantsPasses (in category 'utilities') -----
- testClassConstantsPasses
-        "Answer if testClassConstants passes. This can be used in e.g. the Kernel Package prolog
-         to test if Float initialize needs to be run."
-        [self new testClassConstants]
-                on: TestResult failure
-                do: [:ex| ^false].
-        ^true!

Item was removed:
- ----- Method: FloatTest>>assert:equals:withinUlp: (in category 'asserting') -----
- assert: expected equals: actual withinUlp: maxUlp
-        self assert: (expected - actual) abs <= (maxUlp * expected asFloat ulp)!

Item was removed:
- ----- Method: FloatTest>>floatLiteralsIn: (in category 'private') -----
- floatLiteralsIn: method
-        | floatLiterals |
-        floatLiterals := OrderedCollection new.
-        method allLiteralsDo:
-                [:lit| lit isFloat ifTrue: [floatLiterals addLast: lit]].
-        ^floatLiterals!

Item was removed:
- ----- Method: FloatTest>>methodContainsFloatLiteral: (in category 'private') -----
- methodContainsFloatLiteral: method
-        method isQuick ifFalse:
-                [method allLiteralsDo:
-                        [:lit| lit isFloat ifTrue: [^true]]].
-        ^false!

Item was removed:
- ----- Method: FloatTest>>methodsMaybeContainingBrokenCompiledConstants (in category 'private') -----
- methodsMaybeContainingBrokenCompiledConstants
-        "Answer a set of all methods in the system which contain float constants that differ from those obtaiuned by
-         recompiling. These may indicate an old compiler issue, or indeed an issue with the current compiler. This is a
-         variant of testCompiledConstants used for collecting the set of methods rather than testing that none exist."
-        | identifiedPatients |
-        identifiedPatients := IdentitySet new.
-        CurrentReadOnlySourceFiles cacheDuring:
-                [self systemNavigation allSelectorsAndMethodsDo:
-                        [:class :selector :method|
-                        (self methodContainsFloatLiteral: method) ifTrue:
-                                [| newMethodAndNode newLiterals oldLiterals |
-                                newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
-                                newLiterals := self floatLiteralsIn: newMethodAndNode method.
-                                oldLiterals  := self floatLiteralsIn: method.
-                                "Convenience doit for recompiling broken methods:..."
-                                "class recompile: selector"
-                                newLiterals size = oldLiterals size
-                                        ifFalse: [identifiedPatients add: method]
-                                        ifTrue:
-                                                [newLiterals with: oldLiterals do:
-                                                        [:new :old|
-                                                        (new asIEEE64BitWord = old asIEEE64BitWord
-                                                         or: [new isNaN and: old isNaN]) ifFalse:
-                                                                [identifiedPatients add: method]]]]]].
-        ^identifiedPatients!

Item was removed:
- ----- Method: FloatTest>>testClassConstants (in category 'tests - characterization') -----
- testClassConstants
-
-        "Test all the class constants that are floats to check that they are valid.
-         Sometimes compiler bugs mean that the initialization method is incorrect, etc"
-        | expectedVariables unexpectedVariables "these two are for determining if this test is correct, not its results"
-          finiteVariables infiniteVariables nanVariables |
-        finiteVariables := #(Pi Halfpi Twopi ThreePi RadiansPerDegree Ln2 Ln10 Sqrt2 E Epsilon MaxVal MaxValLn NegativeZero).
-        infiniteVariables := #(Infinity NegativeInfinity).
-        nanVariables := #(NaN).
-        expectedVariables := Set new.
-        unexpectedVariables := Set new.
-        Float classPool keysAndValuesDo:
-                [:name :value|
-                value isFloat
-                        ifTrue:
-                                [(finiteVariables includes: name) ifTrue:
-                                        [expectedVariables add: name.
-                                         self assert: value isFinite.
-                                         self deny: value isInfinite.
-                                         self deny: value isNaN].
-                                (infiniteVariables includes: name) ifTrue:
-                                        [expectedVariables add: name.
-                                         self deny: value isFinite.
-                                         self assert: value isInfinite.
-                                         self deny: value isNaN].
-                                (nanVariables includes: name) ifTrue:
-                                        [expectedVariables add: name.
-                                         self deny: value isFinite.
-                                         self deny: value isInfinite.
-                                         self assert: value isNaN].
-                                (expectedVariables includes: name) ifFalse:
-                                        [unexpectedVariables add: name]]
-                        ifFalse:
-                                [self deny: ((finiteVariables includes: name) or: [(infiniteVariables includes: name) or: [nanVariables includes: name]])]].
-        "Now check that test itself is working as intended..."
-        self assert: unexpectedVariables isEmpty.
-        self assert: expectedVariables = (finiteVariables, infiniteVariables, nanVariables) asSet!

Item was removed:
- ----- Method: FloatTest>>testCloseToFurthestCloseToNeasrest (in category 'tests - compare') -----
- testCloseToFurthestCloseToNeasrest
-        | x nearest furthest |
-        x := 1.0e-6.
-        nearest := 1.0e-7.
-        furthest := 0.0.
-        self assert: (x - nearest) abs < (x - furthest) abs.
-        self assert: (x closeTo: furthest) ==> (x closeTo: nearest)!

Item was removed:
- ----- Method: FloatTest>>testCloseToIsSymmetric (in category 'tests - compare') -----
- testCloseToIsSymmetric
-        self assert: ((1<<2000) reciprocal closeTo: 1.0e-6) equals: (1.0e-6 closeTo: (1<<2000) reciprocal)!

Item was removed:
- ----- Method: FloatTest>>testCompiledConstants (in category 'tests') -----
- testCompiledConstants
-        "Test that any methods containing a floating point literal have been correctly compiled."
-        CurrentReadOnlySourceFiles cacheDuring:
-                [self systemNavigation allSelectorsAndMethodsDo:
-                        [:class :selector :method|
-                        (self methodContainsFloatLiteral: method) ifTrue:
-                                [| newMethodAndNode newLiterals oldLiterals |
-                                newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
-                                newLiterals := self floatLiteralsIn: newMethodAndNode method.
-                                oldLiterals  := self floatLiteralsIn: method.
-                                "Convenience doit for recompiling broken methods:..."
-                                "class recompile: selector"
-                                self assert: newLiterals size = oldLiterals size.
-                                newLiterals with: oldLiterals do:
-                                        [:new :old|
-                                        self assert: (new asIEEE64BitWord = old asIEEE64BitWord
-                                                                or: [new isNaN and: old isNaN])]]]]!

Item was removed:
- ----- Method: FloatTest>>testLog2near1 (in category 'tests - mathematical functions') -----
- testLog2near1
-        self assert: 1.0 predecessor ln / 2 ln equals: 1.0 predecessor log2 withinUlp: 2.
-        self assert: 1.0 successor ln / 2 ln equals: 1.0 successor log2 withinUlp: 2!

Item was removed:
- TestCase subclass: #MethodContextTest
-        instanceVariableNames: 'aCompiledMethod aReceiver aMethodContext aSender'
-        classVariableNames: ''
-        poolDictionaries: ''
-        category: 'KernelTests-Methods'!
-
- !MethodContextTest commentStamp: 'eem 3/30/2017 17:42' prior: 0!
- I am an SUnit Test of Context. See also BlockClosureTest.
- See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak see http://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ and http://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecodes/.  (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
- My fixtures are:
- aReceiver         - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
- aSender           - just some arbitrary object, thisContext
- aCompiledMethod - just some arbitrary method, "Rectangle rightCenter".
- aMethodContext   - just some arbitray context ... 
-
- !

Item was removed:
- ----- Method: MethodContextTest>>privRestartTest (in category 'private') -----
- privRestartTest
-        "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
-        |a firstTimeThrough |
-        firstTimeThrough := true.
-        a := 10.
-       
-        self assert: 30 equals: [|b|
-                self assert: 10 = a .
-                self assert: nil == b.
-                b := a + 20.
-                firstTimeThrough ifTrue: [
-                        firstTimeThrough := false.
-                        thisContext restart.].
-                b] value
- !

Item was removed:
- ----- Method: MethodContextTest>>setUp (in category 'running') -----
- setUp
-        super setUp.
-        aCompiledMethod := Rectangle methodDict at: #rightCenter.
-        aReceiver := 100@100 corner: 200@200.
-        aSender := thisContext.
-        aMethodContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !

Item was removed:
- ----- Method: MethodContextTest>>testActivateReturnValue (in category 'tests') -----
- testActivateReturnValue
-        self assert:  (aSender activateReturn: aMethodContext value: #()) isContext.
-        self assert:  ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).!

Item was removed:
- ----- Method: MethodContextTest>>testCopyStack (in category 'tests') -----
- testCopyStack
-        self assert: aMethodContext copyStack printString = aMethodContext printString.!

Item was removed:
- ----- Method: MethodContextTest>>testCopyTo (in category 'tests') -----
- testCopyTo
-
-        | context depth targetSender |
-        context := thisContext.
-        depth := 1.
-        targetSender := context.
-        [ (targetSender := targetSender sender) isNil ] whileFalse: [
-                | original copy |
-                original := context.
-                copy := context copyTo: targetSender.
-                1 to: depth do: [ :index |
-                        index = 1 ifFalse: [
-                                "Since we're copying thisContext, the pc and stackPtr may be different for the current frame."
-                                self
-                                        assert: original pc equals: copy pc;
-                                        assert: original stackPtr equals: copy stackPtr ].
-                        self
-                                deny: original == copy;
-                                assert: original method equals: copy method;
-                                assert: original closure equals: copy closure;
-                                assert: original receiver equals: copy receiver.
-                        original := original sender.
-                        copy := copy sender ].
-                self
-                        assert: copy isNil;
-                        assert: original == targetSender.
-                depth := depth + 1 ]!

Item was removed:
- ----- Method: MethodContextTest>>testFindContextSuchThat (in category 'tests') -----
- testFindContextSuchThat
-        self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString.
-        self assert: (aMethodContext hasContext: aMethodContext). !

Item was removed:
- ----- Method: MethodContextTest>>testMethodContext (in category 'tests') -----
- testMethodContext
-        self assert: aMethodContext home notNil.
-        self assert: aMethodContext receiver notNil.
-        self assert: aMethodContext method isCompiledMethod.!

Item was removed:
- ----- Method: MethodContextTest>>testMethodIsBottomContext (in category 'tests') -----
- testMethodIsBottomContext
-        self assert: aMethodContext bottomContext = aSender.
-        self assert: aMethodContext secondFromBottom = aMethodContext.!

Item was removed:
- ----- Method: MethodContextTest>>testRestart (in category 'tests') -----
- testRestart
-        self should: [self privRestartTest] notTakeMoreThan: 0.1 second!

Item was removed:
- ----- Method: MethodContextTest>>testReturn (in category 'tests') -----
- testReturn
-        "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
-        aMethodContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
-        self assert: (aMethodContext return: 5) = 5!

Item was removed:
- ----- Method: MethodContextTest>>testSetUp (in category 'tests') -----
- testSetUp
-        "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
-        self assert: aMethodContext isContext.
-        self deny: aMethodContext isExecutingBlock.
-        self deny: aMethodContext isClosure.
-        self deny: aMethodContext isDead.
-        "self assert: aMethodContext home = aReceiver."
-        "self assert: aMethodContext blockHome = aReceiver."
-        self assert: aMethodContext receiver = aReceiver.
-        self assert: aMethodContext method isCompiledMethod.
-        self assert: aMethodContext method = aCompiledMethod.
-        self assert: aMethodContext methodNode selector = #rightCenter.
-        self assert: (aMethodContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
-        self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'.
- !

Item was removed:
- TestCase subclass: #ModelTest
-        instanceVariableNames: ''
-        classVariableNames: ''
-        poolDictionaries: ''
-        category: 'KernelTests-Models'!

Item was removed:
- ----- Method: ModelTest>>testCopyDependents (in category 'tests') -----
- testCopyDependents
-
-        | bar foo |
-        foo := Model new.
-        foo addDependent: 42.
-        self assert: {42} equals: foo dependents asArray.
-       
-        bar := foo copy.
-        self assert: bar dependents isEmpty.!

Item was removed:
- ----- Method: NumberTest>>testExactLog2 (in category 'tests') -----
- testExactLog2
-        -10 to: 10 do: [:i | self assert: i equals: (2 raisedToInteger: i) log2].
-        Float emin - Float precision + 1 to: Float emax do: [:i | self assert: i equals: (1.0 timesTwoPower: i) log2].!

Item was removed:
- ----- Method: NumberTest>>testLog2doesNotOverflow (in category 'tests') -----
- testLog2doesNotOverflow
-        "Note: though this is not a strict identity, we can use strict Float equality here"
-        self assert: 3000.0 equals: ((1 bitShift: 3000) - 1) log2.
-        self assert: 1500.0 equals: (((1 bitShift: 3000) - 1) / (1 bitShift: 1500)) log2.!

Item was removed:
- ----- Method: NumberTest>>testLog2doesNotUnderflow (in category 'tests') -----
- testLog2doesNotUnderflow
-        "Note: though this is not a strict identity, we can use strict Float equality here"
-        self assert: -2000.0 equals: ((1 bitShift: 2000) - 1) reciprocal log2!

Item was removed:
- ----- Method: ObjectTest>>testCopyDependents (in category 'tests') -----
- testCopyDependents
-
-        | bar foo |
-        foo := Object new.
-        foo addDependent: 42.
-        self assert: {42} equals: foo dependents asArray.
-       
-        bar := foo copy.
-        self assert: bar dependents isEmpty.!

Item was removed:
- ----- Method: ProcessTest>>genuineProcess (in category 'support') -----
- genuineProcess
-
-        "Usually, we don't want to expose this from the class under test."
-        ^ Processor instVarNamed: 'genuineProcess'!

Item was removed:
- ----- Method: ProcessTest>>testEvaluateOnBehalfOf (in category 'tests') -----
- testEvaluateOnBehalfOf
-
-        | p1 p2 sem results |
-        self genuineProcess == Processor activeProcess
-                ifFalse: [self fail: 'Cannot debug this test'].
-       
-        sem := Semaphore new.
-        p1 := [] newProcess.
-        p1 environmentAt: #foo put: 1.
-        p2 := [
-                Processor activeProcess environmentAt: #foo put: 2.
-                results := {
-                        Processor activeProcess environmentAt: #foo.
-                        self genuineProcess environmentAt: #foo.
-                        Processor activeProcess
-                                evaluate: [Processor activeProcess environmentAt: #foo]
-                                onBehalfOf: p1.
-                        Processor activeProcess
-                                evaluate: [self genuineProcess environmentAt: #foo]
-                                onBehalfOf: p1.
-                        Processor activeProcess environmentAt: #foo }.
-                sem signal
-        ] newProcess.
-       
-        p2 resume.
-        sem wait.
-       
-        self assert: {2. 2. 1. 2. 2} equals: results.!

Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulRunning (in category 'tests') -----
- testProcessFaithfulRunning
-        "While simulating a process using #runUntilErrorOrReturnFrom:, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
-
-        | process result |
-        process := Process forBlock: [
-                result := Processor activeProcess environmentAt: #foo].
-        process environmentAt: #foo put: 42.
-       
-        process complete: process suspendedContext.
-       
-        self assert: 42 equals: result.!

Item was removed:
- ----- Method: ProcessTest>>testProcessFaithfulSimulation (in category 'tests') -----
- testProcessFaithfulSimulation
-        "While simulating a process using the bytecode simulation machinery, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
-
-        | process result |
-        process := Process forBlock: [
-                result := Processor activeProcess environmentAt: #foo].
-        process environmentAt: #foo put: 42.
-       
-        process runUntil: [:context | context isDead].
-       
-        self assert: 42 equals: result.!

Item was removed:
- ----- Method: PromiseTest>>testAnErrorInOnRejectedRejectsPromise (in category 'tests - monad') -----
- testAnErrorInOnRejectedRejectsPromise
-        "https://promisesaplus.com section 2.2.7.2"
-        | p q error |
-        p := Promise new.
-        q := p ifRejected: [:e | (error := KeyNotFound new) signal].
-        p rejectWith: 1.
-        self assert: p isRejected description: 'Original Promise not rejected'.
-        self assert: q isRejected description: 'Broken Promise not rejected'.
-        self assert: p error = 1.
-        self assert: q error == error.!

Item was changed:
  ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'tests - monad') -----
  testAnErrorInThenRejectsPromise
+        | p q |
-        "https://promisesaplus.com section 2.2.7.2"
-        | p q error |
         p := Promise new.
+        q := p then: [:v | KeyNotFound signal].
-        q := p then: [:v | (error := KeyNotFound new) signal].
         p resolveWith: 1.
         self deny: p isRejected description: 'Original Promise rejected'.
+        self assert: q isRejected description: 'Broken Promise not rejected'.!
-        self assert: q isRejected description: 'Broken Promise not rejected'.
-        self assert: p value = 1.
-        self assert: q error == error.!

Item was removed:
- ----- Method: PromiseTest>>testNilErrBlockPropagation (in category 'tests - monad') -----
- testNilErrBlockPropagation
-        "https://promisesaplus.com section 2.2.7.4"
-        | p q |
-        p := Promise new.
-        q := p then: [:v | self error: 'Shouldn''t call resolvedBlock'] ifRejected: nil.
-        p rejectWith: 1.
-        self assert: p isRejected.
-        self assert: q isRejected.
-        self assert: p error equals: 1.
-        self assert: q error equals: 1.!

Item was removed:
- ----- Method: PromiseTest>>testNilResolvedBlockPropagation (in category 'tests - monad') -----
- testNilResolvedBlockPropagation
-        "https://promisesaplus.com section 2.2.7.3"
-        | p q |
-        p := Promise new.
-        q := p then: nil ifRejected: [:e | self error: 'Shouldn''t call errBlock'].
-        p resolveWith: 1.
-        self assert: p isResolved.
-        self assert: q isResolved.
-        self assert: p value equals: 1.
-        self assert: q value equals: 1.!

Item was changed:
  ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'tests - monad') -----
  testifRejectedRunsBlockIfPromiseFails
-        "https://promisesaplus.com section 2.2.7.1"
         | p q error |
         error := nil.
         p := Promise new.
+        q := p ifRejected: [:e | error := e].
-        q := p ifRejected: [:e | error := e "N.B. returns a value, does not signal an Exception"].
         p rejectWith: KeyNotFound new.
+        self assert: q isRejected.
+        self assert: KeyNotFound equals: error class.!
-        self assert: q isResolved.
-        self assert: KeyNotFound equals: error class.
-        self assert: q value == error.!

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

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

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

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

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

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

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

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

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

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

Item was removed:
- 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 removed:
- ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') -----
- initialize
-       
-        ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()!

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

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

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') -----
- testBasicProxyReadOnly
-        self alwaysReadOnlyObjects do: [ :each |
-                self assert: (MirrorPrimitives isObjectReadOnly: each) equals: true ]!

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

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

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

Item was removed:
- ----- 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 removed:
- ----- 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!

Item was removed:
- ----- 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!

Item was removed:
- ----- 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!

Item was removed:
- ----- 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!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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
- !

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccessProxy (in category 'tests - proxy') -----
- testSetIsReadOnlySuccessProxy
-        self maybeReadOnlyObjects do: [ :each |
-                self
-                        testProxyObject: each
-                        initialState: false
-                        tuples: #( (true false true) (false true false) ) ]!

> On 20. Mar 2021, at 19:25, Thiede, Christoph <[hidden email]> wrote:
>
> Hmm, the diff is broken ... Looked fine in my image. :-(

It has two ancestors, tho…
-t

>
> Best,
> Christoph
> Von: Squeak-dev <[hidden email]> im Auftrag von [hidden email]<[hidden email]>
> Gesendet: Samstag, 20. März 2021 19:17:50
> An: [hidden email]
> Betreff: [squeak-dev] The Inbox: KernelTests-ct.395.mcz
> 
> A new version of KernelTests was added to project The Inbox:
> http://source.squeak.org/inbox/KernelTests-ct.395.mcz
>
> ==================== Summary ====================
>
> Name: KernelTests-ct.395
> Author: ct
> Time: 20 March 2021, 7:17:49.390742 pm
> UUID: 76e4d450-32dd-d24c-8aad-68ad212ec955
> Ancestors: KernelTests-mt.394, KernelTests-ct.375
>
> Tests simulation of #perform:... primitives 83, 84, and 100. Complements Kernel-ct.1367. Reuploaded to add another fixture for the mirror primitive variant of primitive 100. Corrected order of assertion arguments.
>
> Replaces KernelTests-ct.38{2,3}, which can be moved into the treated inbox.
>
> Depends indeed not only on KernelTests-mt.394 but also on KernelTests-ct.375, it would be nice if we could get the latter merged soon, this has already been causing too many merge conflicts in the past. :-)
>
> =============== Diff against KernelTests-mt.394 ===============
>
> 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'!
> - SystemOrganization addCategory: #'KernelTests-Models'!
>
> Item was changed:
>   ----- Method: AllocationTest>>testOutOfMemorySignal (in category 'tests') -----
>   testOutOfMemorySignal
> +        "Ensure that OutOfMemory is signaled eventually"
> -        "Ensure that OutOfMemory is signaled eventually. Restrain the available memory first to not stress the machine too much."
> -       
>          | sz |
>          self setFreeSpaceLimitOf: 1024 * 1024 * 1024 * (Smalltalk wordSize = 8
>                                                                                                                  ifTrue: [4]
>                                                                                                                  ifFalse: [1.5])
>                  around:
>                          [sz := 512*1024*1024. "work around the 1GB alloc bug"
> +                         self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].
> +
> +        "Call me when this test fails, I want your machine."
> +        "Current (2017) Spur VMs fail new: & basicNew: with #'bad argument' if given other than a non-negative SmallInteger."
> +        sz := 1024*1024*1024*1024.
> +        self should: [Array new: sz]
> +                raise: OutOfMemory, Error
> +                withExceptionDo:
> +                        [:ex|
> +                         ex class == Error ifTrue:
> +                                [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument']]]!
> -                         self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory].!
>
> Item was removed:
> - ----- Method: AllocationTest>>testOutOfMemorySignalExtreme (in category 'tests') -----
> - testOutOfMemorySignalExtreme
> -        "Try to allocate a ridiculous amount of memory and check whether the expected error is signaled. Call Eliot when this test fails, he want your machine. :-)
> -       
> -        Note that current (2017) Spur VMs fail in #new: and #basicNew: with #'bad argument' if given other than a non-negative SmallInteger.
> -       
> -        Also note that this test can be quite stressful to your machine depending on how your operating system allocates the required memory behind the curtains. Better not triggering some robot fetching a tape from somewhere..."
> -       
> -        | sz |
> -        sz := 1024*1024*1024*1024. "= 1 TiB"
> -        self should: [Array new: sz]
> -                raise: OutOfMemory, Error
> -                withExceptionDo:
> -                        [:ex|
> -                         ex class == Error ifTrue:
> -                                [self assert: [ex messageText includesSubstring: 'basicNew: with invalid argument']]]!
>
> Item was removed:
> - ----- Method: BlockClosureTest>>return: (in category 'private') -----
> - return: something
> -
> -        ^ something!
>
> Item was removed:
> - ----- Method: BlockClosureTest>>testMoreThanOnce (in category 'tests - evaluating') -----
> - testMoreThanOnce
> -        "Make sure that we can use once more than once"
> -        | moreThanOnce |
> -        moreThanOnce := (1 to: 3) collect: [:e | [String new] once -> [Array new] once].
> -        self assert: (moreThanOnce allSatisfy: [:each | each key isString]).
> -        self assert: (moreThanOnce allSatisfy: [:each | each value isArray]).
> -        self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
> -        self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).!
>
> Item was removed:
> - ----- Method: BlockClosureTest>>testMoreThanOnceForEqualBlocks (in category 'tests - evaluating') -----
> - testMoreThanOnceForEqualBlocks
> -        "Make sure that we can use once more than once"
> -        | moreThanOnce |
> -        moreThanOnce := (1 to: 3) collect: [:e | [Object new] once -> [Object new] once].
> -        self assert: (moreThanOnce allSatisfy: [:each | each key == moreThanOnce first key]).
> -        self assert: (moreThanOnce allSatisfy: [:each | each value == moreThanOnce first value]).
> -        self assert: (moreThanOnce noneSatisfy: [:each | each key == each value]).!
>
> Item was changed:
>   ----- Method: BlockClosureTest>>testRunSimulated (in category 'tests') -----
>   testRunSimulated
> +        self assert: Rectangle equals: (Context runSimulated: aBlockClosure asContext) class!
> -        self assert: Rectangle equals:
> -                (Context runSimulated: aBlockClosure asContext) class.
> -        self assert: 42 equals:
> -                (Context runSimulated: [self return: 42]).
> -        self
> -                should: [Context runSimulated: [self halt]]
> -                raise: Halt.!
>
> Item was removed:
> - ----- Method: BlockClosureTest>>testRunSimulatedContextAtEachStep (in category 'tests') -----
> - testRunSimulatedContextAtEachStep
> -
> -        | context |
> -        context := aBlockClosure asContext.
> -        self assert: Rectangle equals: (thisContext
> -                runSimulated: context
> -                contextAtEachStep: [:ctxt | self assert:
> -                        [ctxt == context or: [ctxt hasSender: context]]]) class.!
>
> Item was changed:
>   ----- Method: BlockClosureTest>>testSetUp (in category 'tests') -----
>   testSetUp
>          "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
>          self deny: aBlockClosure isContext.
>          self assert: aBlockClosure isClosure.
>          self assert: aBlockClosure home = homeOfABlockClosure.
>          self assert: aBlockClosure receiver = self.
> +        self assert: aBlockClosure method isCompiledMethod!
> -        self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
> -                ifTrue: [aBlockClosure method isCompiledBlock]
> -                ifFalse: [aBlockClosure method isCompiledMethod])!
>
> Item was changed:
>   ----- Method: BlockClosureTest>>testTallyInstructions (in category 'tests') -----
>   testTallyInstructions
> +        self assert: (Context tallyInstructions: aBlockClosure asContext) size = 15!
> -        self assert: ((aBlockClosure isMemberOf: FullBlockClosure)
> -                        ifTrue: [14]
> -                        ifFalse: [15])
> -                equals: (Context tallyInstructions: aBlockClosure asContext) size!
>
> Item was changed:
>   ----- Method: ClassTest>>testChangeClassOf (in category 'tests') -----
>   testChangeClassOf
>          "Exercise primitiveChangeClass (primitive 115) for a common use case. This should pass
>          for any Squeak image format (but failed for image format 68002 prior to VM fix)"
>  
> +        self shouldnt: [Inspector new primitiveChangeClassTo: CompiledMethodInspector new] raise: Error!
> -        self shouldnt: [Exception new primitiveChangeClassTo: Error new] raise: Error!
>
> Item was changed:
>   ----- Method: CompiledMethodTest>>testClosureSize (in category 'tests - closures') -----
>   testClosureSize
> +        self
> +                assert: ((self class >> #withClosure) embeddedBlockClosures at: 1) size
> +                        equals: 2;
> +                assert: ((self class >> #withClosureNoNLR) embeddedBlockClosures at: 1) size
> +                        equals: 2!
> -        | compiledMethod expectedSize |
> -        compiledMethod := (self class >> #withClosure).
> -        expectedSize := compiledMethod bytecodeSetName
> -                caseOf: {
> -                        ['SistaV1'] -> [3].
> -                        ['V3PlusClosures'] -> [2]}.
> -        self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.
> -        compiledMethod := (self class >> #withClosureNoNLR).
> -        expectedSize := compiledMethod bytecodeSetName
> -                caseOf: {
> -                        ['SistaV1'] -> [3].
> -                        ['V3PlusClosures'] -> [2]}.
> -        self assert: expectedSize equals: (compiledMethod embeddedBlockClosures at: 1) size.!
>
> Item was added:
> + TestCase subclass: #ContextTest
> +        instanceVariableNames: 'aCompiledMethod aReceiver aSender aContext'
> +        classVariableNames: ''
> +        poolDictionaries: ''
> +        category: 'KernelTests-Methods'!
> +
> + !ContextTest commentStamp: 'ct 1/27/2020 13:03' prior: 0!
> + I am an SUnit Test of Context. See also BlockClosureTest.
> + See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak seehttp://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ andhttp://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecodes/.  (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
> + My fixtures are:
> + aReceiver                     - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
> + aSender                       - just some arbitrary object, thisContext
> + aCompiledMethod       - just some arbitrary method, "Rectangle rightCenter".
> + aContext                      - just some arbitray context ... 
> +
> + !
>
> Item was added:
> + ----- Method: ContextTest>>privRestartTest (in category 'private') -----
> + privRestartTest
> +        "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
> +        |a firstTimeThrough |
> +        firstTimeThrough := true.
> +        a := 10.
> +       
> +        self assert: 30 equals: [|b|
> +                self assert: 10 = a .
> +                self assert: nil == b.
> +                b := a + 20.
> +                firstTimeThrough ifTrue: [
> +                        firstTimeThrough := false.
> +                        thisContext restart.].
> +                b] value
> + !
>
> Item was added:
> + ----- Method: ContextTest>>setUp (in category 'running') -----
> + setUp
> +        super setUp.
> +        aCompiledMethod := Rectangle methodDict at: #rightCenter.
> +        aReceiver := 100@100 corner: 200@200.
> +        aSender := thisContext.
> +        aContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !
>
> Item was added:
> + ----- Method: ContextTest>>testActivateReturnValue (in category 'tests') -----
> + testActivateReturnValue
> +        self assert:  (aSender activateReturn: aContext value: #()) isContext.
> +        self assert:  ((aSender activateReturn: aContext value: #()) receiver = aContext).!
>
> Item was added:
> + ----- Method: ContextTest>>testCopyStack (in category 'tests') -----
> + testCopyStack
> +        self assert: aContext copyStack printString = aContext printString.!
>
> Item was added:
> + ----- Method: ContextTest>>testFindContextSuchThat (in category 'tests') -----
> + testFindContextSuchThat
> +        self assert: (aContext findContextSuchThat: [:each| true]) printString = aContext printString.
> +        self assert: (aContext hasContext: aContext). !
>
> Item was added:
> + ----- Method: ContextTest>>testMethodContext (in category 'tests') -----
> + testMethodContext
> +        self assert: aContext home notNil.
> +        self assert: aContext receiver notNil.
> +        self assert: aContext method isCompiledMethod.!
>
> Item was added:
> + ----- Method: ContextTest>>testMethodIsBottomContext (in category 'tests') -----
> + testMethodIsBottomContext
> +        self assert: aContext bottomContext = aSender.
> +        self assert: aContext secondFromBottom = aContext.!
>
> Item was added:
> + ----- Method: ContextTest>>testPrimitive100 (in category 'tests') -----
> + testPrimitive100
> +
> +        {
> +                {#isNil. {}. Object}. "valid 0-arg message"
> +                {#=. {true}. UndefinedObject}. "valid unary message"
> +                {#ifNil:ifNotNil:. {[2]. [:x | x]}. Object}. "valid binary message"
> +                {{}. #=. {true}. SequenceableCollection}. "mirror primitive"
> +                {#isNil}. "missing arguments"
> +                {#isNil. 'not an array'}. "invalid arguments"
> +                {#isNil. {}}. "missing lookupClass"
> +                {#isNil. {'excess arg'}. Object}. "too many arguments"
> +                {#=. {}. UndefinedObject}. "missing argument"
> +                {#isNil. {}. Boolean}. "lookupClass not in inheritance chain"
> +        } do: [:args |
> +                self
> +                        assert: (nil tryPrimitive: 100 withArgs: args)
> +                        equals: (Context runSimulated: [nil tryPrimitive: 100 withArgs: args])].!
>
> Item was added:
> + ----- Method: ContextTest>>testPrimitive83 (in category 'tests') -----
> + testPrimitive83
> +
> +        {
> +                {#isNil}. "valid 0-arg message"
> +                {#=. true}. "valid unary message"
> +                {#ifNil:ifNotNil:. [2]. [:x | x]}. "valid binary message"
> +                {#isNil. 'excess arg'}. "too many arguments"
> +                {#=}. "missing argument"
> +        } do: [:args |
> +                self
> +                        assert: (nil tryPrimitive: 83 withArgs: args)
> +                        equals: (Context runSimulated: [nil tryPrimitive: 83 withArgs: args])].!
>
> Item was added:
> + ----- Method: ContextTest>>testPrimitive84 (in category 'tests') -----
> + testPrimitive84
> +
> +        {
> +                {#isNil. {}}. "valid 0-arg message"
> +                {#=. {true}}. "valid unary message"
> +                {#ifNil:ifNotNil:. {[2]. [:x | x]}}. "valid binary message"
> +                {#isNil}. "missing arguments"
> +                {#isNil. 'not an array'}. "invalid arguments"
> +                {#isNil. {'excess arg'}}. "too many arguments"
> +                {#=. {}}. "missing argument"
> +        } do: [:args |
> +                self
> +                        assert: (nil tryPrimitive: 84 withArgs: args)
> +                        equals: (Context runSimulated: [nil tryPrimitive: 84 withArgs: args])].!
>
> Item was added:
> + ----- Method: ContextTest>>testRestart (in category 'tests') -----
> + testRestart
> +        self should: [self privRestartTest] notTakeMoreThan: 0.1 second!
>
> Item was added:
> + ----- Method: ContextTest>>testReturn (in category 'tests') -----
> + testReturn
> +        "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
> +        aContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
> +        self assert: (aContext return: 5) = 5!
>
> Item was added:
> + ----- Method: ContextTest>>testSetUp (in category 'tests') -----
> + testSetUp
> +        "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
> +        self assert: aContext isContext.
> +        self deny: aContext isExecutingBlock.
> +        self deny: aContext isClosure.
> +        self deny: aContext isDead.
> +        "self assert: aMethodContext home = aReceiver."
> +        "self assert: aMethodContext blockHome = aReceiver."
> +        self assert: aContext receiver = aReceiver.
> +        self assert: aContext method isCompiledMethod.
> +        self assert: aContext method = aCompiledMethod.
> +        self assert: aContext methodNode selector = #rightCenter.
> +        self assert: (aContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
> +        self assert: aContext client printString = 'ContextTest>>#testSetUp'.
> + !
>
> Item was removed:
> - ----- Method: FloatTest class>>testClassConstantsPasses (in category 'utilities') -----
> - testClassConstantsPasses
> -        "Answer if testClassConstants passes. This can be used in e.g. the Kernel Package prolog
> -         to test if Float initialize needs to be run."
> -        [self new testClassConstants]
> -                on: TestResult failure
> -                do: [:ex| ^false].
> -        ^true!
>
> Item was removed:
> - ----- Method: FloatTest>>assert:equals:withinUlp: (in category 'asserting') -----
> - assert: expected equals: actual withinUlp: maxUlp
> -        self assert: (expected - actual) abs <= (maxUlp * expected asFloat ulp)!
>
> Item was removed:
> - ----- Method: FloatTest>>floatLiteralsIn: (in category 'private') -----
> - floatLiteralsIn: method
> -        | floatLiterals |
> -        floatLiterals := OrderedCollection new.
> -        method allLiteralsDo:
> -                [:lit| lit isFloat ifTrue: [floatLiterals addLast: lit]].
> -        ^floatLiterals!
>
> Item was removed:
> - ----- Method: FloatTest>>methodContainsFloatLiteral: (in category 'private') -----
> - methodContainsFloatLiteral: method
> -        method isQuick ifFalse:
> -                [method allLiteralsDo:
> -                        [:lit| lit isFloat ifTrue: [^true]]].
> -        ^false!
>
> Item was removed:
> - ----- Method: FloatTest>>methodsMaybeContainingBrokenCompiledConstants (in category 'private') -----
> - methodsMaybeContainingBrokenCompiledConstants
> -        "Answer a set of all methods in the system which contain float constants that differ from those obtaiuned by
> -         recompiling. These may indicate an old compiler issue, or indeed an issue with the current compiler. This is a
> -         variant of testCompiledConstants used for collecting the set of methods rather than testing that none exist."
> -        | identifiedPatients |
> -        identifiedPatients := IdentitySet new.
> -        CurrentReadOnlySourceFiles cacheDuring:
> -                [self systemNavigation allSelectorsAndMethodsDo:
> -                        [:class :selector :method|
> -                        (self methodContainsFloatLiteral: method) ifTrue:
> -                                [| newMethodAndNode newLiterals oldLiterals |
> -                                newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
> -                                newLiterals := self floatLiteralsIn: newMethodAndNode method.
> -                                oldLiterals  := self floatLiteralsIn: method.
> -                                "Convenience doit for recompiling broken methods:..."
> -                                "class recompile: selector"
> -                                newLiterals size = oldLiterals size
> -                                        ifFalse: [identifiedPatients add: method]
> -                                        ifTrue:
> -                                                [newLiterals with: oldLiterals do:
> -                                                        [:new :old|
> -                                                        (new asIEEE64BitWord = old asIEEE64BitWord
> -                                                         or: [new isNaN and: old isNaN]) ifFalse:
> -                                                                [identifiedPatients add: method]]]]]].
> -        ^identifiedPatients!
>
> Item was removed:
> - ----- Method: FloatTest>>testClassConstants (in category 'tests - characterization') -----
> - testClassConstants
> -
> -        "Test all the class constants that are floats to check that they are valid.
> -         Sometimes compiler bugs mean that the initialization method is incorrect, etc"
> -        | expectedVariables unexpectedVariables "these two are for determining if this test is correct, not its results"
> -          finiteVariables infiniteVariables nanVariables |
> -        finiteVariables := #(Pi Halfpi Twopi ThreePi RadiansPerDegree Ln2 Ln10 Sqrt2 E Epsilon MaxVal MaxValLn NegativeZero).
> -        infiniteVariables := #(Infinity NegativeInfinity).
> -        nanVariables := #(NaN).
> -        expectedVariables := Set new.
> -        unexpectedVariables := Set new.
> -        Float classPool keysAndValuesDo:
> -                [:name :value|
> -                value isFloat
> -                        ifTrue:
> -                                [(finiteVariables includes: name) ifTrue:
> -                                        [expectedVariables add: name.
> -                                         self assert: value isFinite.
> -                                         self deny: value isInfinite.
> -                                         self deny: value isNaN].
> -                                (infiniteVariables includes: name) ifTrue:
> -                                        [expectedVariables add: name.
> -                                         self deny: value isFinite.
> -                                         self assert: value isInfinite.
> -                                         self deny: value isNaN].
> -                                (nanVariables includes: name) ifTrue:
> -                                        [expectedVariables add: name.
> -                                         self deny: value isFinite.
> -                                         self deny: value isInfinite.
> -                                         self assert: value isNaN].
> -                                (expectedVariables includes: name) ifFalse:
> -                                        [unexpectedVariables add: name]]
> -                        ifFalse:
> -                                [self deny: ((finiteVariables includes: name) or: [(infiniteVariables includes: name) or: [nanVariables includes: name]])]].
> -        "Now check that test itself is working as intended..."
> -        self assert: unexpectedVariables isEmpty.
> -        self assert: expectedVariables = (finiteVariables, infiniteVariables, nanVariables) asSet!
>
> Item was removed:
> - ----- Method: FloatTest>>testCloseToFurthestCloseToNeasrest (in category 'tests - compare') -----
> - testCloseToFurthestCloseToNeasrest
> -        | x nearest furthest |
> -        x := 1.0e-6.
> -        nearest := 1.0e-7.
> -        furthest := 0.0.
> -        self assert: (x - nearest) abs < (x - furthest) abs.
> -        self assert: (x closeTo: furthest) ==> (x closeTo: nearest)!
>
> Item was removed:
> - ----- Method: FloatTest>>testCloseToIsSymmetric (in category 'tests - compare') -----
> - testCloseToIsSymmetric
> -        self assert: ((1<<2000) reciprocal closeTo: 1.0e-6) equals: (1.0e-6 closeTo: (1<<2000) reciprocal)!
>
> Item was removed:
> - ----- Method: FloatTest>>testCompiledConstants (in category 'tests') -----
> - testCompiledConstants
> -        "Test that any methods containing a floating point literal have been correctly compiled."
> -        CurrentReadOnlySourceFiles cacheDuring:
> -                [self systemNavigation allSelectorsAndMethodsDo:
> -                        [:class :selector :method|
> -                        (self methodContainsFloatLiteral: method) ifTrue:
> -                                [| newMethodAndNode newLiterals oldLiterals |
> -                                newMethodAndNode := class compile: method getSource asString notifying: nil trailer: CompiledMethodTrailer empty ifFail: nil.
> -                                newLiterals := self floatLiteralsIn: newMethodAndNode method.
> -                                oldLiterals  := self floatLiteralsIn: method.
> -                                "Convenience doit for recompiling broken methods:..."
> -                                "class recompile: selector"
> -                                self assert: newLiterals size = oldLiterals size.
> -                                newLiterals with: oldLiterals do:
> -                                        [:new :old|
> -                                        self assert: (new asIEEE64BitWord = old asIEEE64BitWord
> -                                                                or: [new isNaN and: old isNaN])]]]]!
>
> Item was removed:
> - ----- Method: FloatTest>>testLog2near1 (in category 'tests - mathematical functions') -----
> - testLog2near1
> -        self assert: 1.0 predecessor ln / 2 ln equals: 1.0 predecessor log2 withinUlp: 2.
> -        self assert: 1.0 successor ln / 2 ln equals: 1.0 successor log2 withinUlp: 2!
>
> Item was removed:
> - TestCase subclass: #MethodContextTest
> -        instanceVariableNames: 'aCompiledMethod aReceiver aMethodContext aSender'
> -        classVariableNames: ''
> -        poolDictionaries: ''
> -        category: 'KernelTests-Methods'!
> -
> - !MethodContextTest commentStamp: 'eem 3/30/2017 17:42' prior: 0!
> - I am an SUnit Test of Context. See also BlockClosureTest.
> - See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. To see how blocks are implemented in this version of Squeak seehttp://www.mirandabanda.org/cogblog/2008/06/07/closures-part-i/ andhttp://www.mirandabanda.org/cogblog/2008/07/22/closures-part-ii-the-bytecodes/.  (The Squeak V3 byte codes are not quite the same as Smalltalk-80, and the SistaV1 byetcodes are quite different.)
> - My fixtures are:
> - aReceiver         - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200"
> - aSender           - just some arbitrary object, thisContext
> - aCompiledMethod - just some arbitrary method, "Rectangle rightCenter".
> - aMethodContext   - just some arbitray context ... 
> -
> - !
>
> Item was removed:
> - ----- Method: MethodContextTest>>privRestartTest (in category 'private') -----
> - privRestartTest
> -        "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out"
> -        |a firstTimeThrough |
> -        firstTimeThrough := true.
> -        a := 10.
> -       
> -        self assert: 30 equals: [|b|
> -                self assert: 10 = a .
> -                self assert: nil == b.
> -                b := a + 20.
> -                firstTimeThrough ifTrue: [
> -                        firstTimeThrough := false.
> -                        thisContext restart.].
> -                b] value
> - !
>
> Item was removed:
> - ----- Method: MethodContextTest>>setUp (in category 'running') -----
> - setUp
> -        super setUp.
> -        aCompiledMethod := Rectangle methodDict at: #rightCenter.
> -        aReceiver := 100@100 corner: 200@200.
> -        aSender := thisContext.
> -        aMethodContext := Context sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). !
>
> Item was removed:
> - ----- Method: MethodContextTest>>testActivateReturnValue (in category 'tests') -----
> - testActivateReturnValue
> -        self assert:  (aSender activateReturn: aMethodContext value: #()) isContext.
> -        self assert:  ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testCopyStack (in category 'tests') -----
> - testCopyStack
> -        self assert: aMethodContext copyStack printString = aMethodContext printString.!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testCopyTo (in category 'tests') -----
> - testCopyTo
> -
> -        | context depth targetSender |
> -        context := thisContext.
> -        depth := 1.
> -        targetSender := context.
> -        [ (targetSender := targetSender sender) isNil ] whileFalse: [
> -                | original copy |
> -                original := context.
> -                copy := context copyTo: targetSender.
> -                1 to: depth do: [ :index |
> -                        index = 1 ifFalse: [
> -                                "Since we're copying thisContext, the pc and stackPtr may be different for the current frame."
> -                                self
> -                                        assert: original pc equals: copy pc;
> -                                        assert: original stackPtr equals: copy stackPtr ].
> -                        self
> -                                deny: original == copy;
> -                                assert: original method equals: copy method;
> -                                assert: original closure equals: copy closure;
> -                                assert: original receiver equals: copy receiver.
> -                        original := original sender.
> -                        copy := copy sender ].
> -                self
> -                        assert: copy isNil;
> -                        assert: original == targetSender.
> -                depth := depth + 1 ]!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testFindContextSuchThat (in category 'tests') -----
> - testFindContextSuchThat
> -        self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString.
> -        self assert: (aMethodContext hasContext: aMethodContext). !
>
> Item was removed:
> - ----- Method: MethodContextTest>>testMethodContext (in category 'tests') -----
> - testMethodContext
> -        self assert: aMethodContext home notNil.
> -        self assert: aMethodContext receiver notNil.
> -        self assert: aMethodContext method isCompiledMethod.!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testMethodIsBottomContext (in category 'tests') -----
> - testMethodIsBottomContext
> -        self assert: aMethodContext bottomContext = aSender.
> -        self assert: aMethodContext secondFromBottom = aMethodContext.!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testRestart (in category 'tests') -----
> - testRestart
> -        self should: [self privRestartTest] notTakeMoreThan: 0.1 second!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testReturn (in category 'tests') -----
> - testReturn
> -        "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp."
> -        aMethodContext := Context sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #().
> -        self assert: (aMethodContext return: 5) = 5!
>
> Item was removed:
> - ----- Method: MethodContextTest>>testSetUp (in category 'tests') -----
> - testSetUp
> -        "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'"
> -        self assert: aMethodContext isContext.
> -        self deny: aMethodContext isExecutingBlock.
> -        self deny: aMethodContext isClosure.
> -        self deny: aMethodContext isDead.
> -        "self assert: aMethodContext home = aReceiver."
> -        "self assert: aMethodContext blockHome = aReceiver."
> -        self assert: aMethodContext receiver = aReceiver.
> -        self assert: aMethodContext method isCompiledMethod.
> -        self assert: aMethodContext method = aCompiledMethod.
> -        self assert: aMethodContext methodNode selector = #rightCenter.
> -        self assert: (aMethodContext methodNodeFormattedAndDecorated: true) selector = #rightCenter.
> -        self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'.
> - !
>
> Item was removed:
> - TestCase subclass: #ModelTest
> -        instanceVariableNames: ''
> -        classVariableNames: ''
> -        poolDictionaries: ''
> -        category: 'KernelTests-Models'!
>
> Item was removed:
> - ----- Method: ModelTest>>testCopyDependents (in category 'tests') -----
> - testCopyDependents
> -
> -        | bar foo |
> -        foo := Model new.
> -        foo addDependent: 42.
> -        self assert: {42} equals: foo dependents asArray.
> -       
> -        bar := foo copy.
> -        self assert: bar dependents isEmpty.!
>
> Item was removed:
> - ----- Method: NumberTest>>testExactLog2 (in category 'tests') -----
> - testExactLog2
> -        -10 to: 10 do: [:i | self assert: i equals: (2 raisedToInteger: i) log2].
> -        Float emin - Float precision + 1 to: Float emax do: [:i | self assert: i equals: (1.0 timesTwoPower: i) log2].!
>
> Item was removed:
> - ----- Method: NumberTest>>testLog2doesNotOverflow (in category 'tests') -----
> - testLog2doesNotOverflow
> -        "Note: though this is not a strict identity, we can use strict Float equality here"
> -        self assert: 3000.0 equals: ((1 bitShift: 3000) - 1) log2.
> -        self assert: 1500.0 equals: (((1 bitShift: 3000) - 1) / (1 bitShift: 1500)) log2.!
>
> Item was removed:
> - ----- Method: NumberTest>>testLog2doesNotUnderflow (in category 'tests') -----
> - testLog2doesNotUnderflow
> -        "Note: though this is not a strict identity, we can use strict Float equality here"
> -        self assert: -2000.0 equals: ((1 bitShift: 2000) - 1) reciprocal log2!
>
> Item was removed:
> - ----- Method: ObjectTest>>testCopyDependents (in category 'tests') -----
> - testCopyDependents
> -
> -        | bar foo |
> -        foo := Object new.
> -        foo addDependent: 42.
> -        self assert: {42} equals: foo dependents asArray.
> -       
> -        bar := foo copy.
> -        self assert: bar dependents isEmpty.!
>
> Item was removed:
> - ----- Method: ProcessTest>>genuineProcess (in category 'support') -----
> - genuineProcess
> -
> -        "Usually, we don't want to expose this from the class under test."
> -        ^ Processor instVarNamed: 'genuineProcess'!
>
> Item was removed:
> - ----- Method: ProcessTest>>testEvaluateOnBehalfOf (in category 'tests') -----
> - testEvaluateOnBehalfOf
> -
> -        | p1 p2 sem results |
> -        self genuineProcess == Processor activeProcess
> -                ifFalse: [self fail: 'Cannot debug this test'].
> -       
> -        sem := Semaphore new.
> -        p1 := [] newProcess.
> -        p1 environmentAt: #foo put: 1.
> -        p2 := [
> -                Processor activeProcess environmentAt: #foo put: 2.
> -                results := {
> -                        Processor activeProcess environmentAt: #foo.
> -                        self genuineProcess environmentAt: #foo.
> -                        Processor activeProcess
> -                                evaluate: [Processor activeProcess environmentAt: #foo]
> -                                onBehalfOf: p1.
> -                        Processor activeProcess
> -                                evaluate: [self genuineProcess environmentAt: #foo]
> -                                onBehalfOf: p1.
> -                        Processor activeProcess environmentAt: #foo }.
> -                sem signal
> -        ] newProcess.
> -       
> -        p2 resume.
> -        sem wait.
> -       
> -        self assert: {2. 2. 1. 2. 2} equals: results.!
>
> Item was removed:
> - ----- Method: ProcessTest>>testProcessFaithfulRunning (in category 'tests') -----
> - testProcessFaithfulRunning
> -        "While simulating a process using #runUntilErrorOrReturnFrom:, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
> -
> -        | process result |
> -        process := Process forBlock: [
> -                result := Processor activeProcess environmentAt: #foo].
> -        process environmentAt: #foo put: 42.
> -       
> -        process complete: process suspendedContext.
> -       
> -        self assert: 42 equals: result.!
>
> Item was removed:
> - ----- Method: ProcessTest>>testProcessFaithfulSimulation (in category 'tests') -----
> - testProcessFaithfulSimulation
> -        "While simulating a process using the bytecode simulation machinery, process variables should be looked up in the process being simulated. Acceptance test for process-faithful debugging, see #evaluate:onBehalfOf:."
> -
> -        | process result |
> -        process := Process forBlock: [
> -                result := Processor activeProcess environmentAt: #foo].
> -        process environmentAt: #foo put: 42.
> -       
> -        process runUntil: [:context | context isDead].
> -       
> -        self assert: 42 equals: result.!
>
> Item was removed:
> - ----- Method: PromiseTest>>testAnErrorInOnRejectedRejectsPromise (in category 'tests - monad') -----
> - testAnErrorInOnRejectedRejectsPromise
> -        "https://promisesaplus.com section 2.2.7.2"
> -        | p q error |
> -        p := Promise new.
> -        q := p ifRejected: [:e | (error := KeyNotFound new) signal].
> -        p rejectWith: 1.
> -        self assert: p isRejected description: 'Original Promise not rejected'.
> -        self assert: q isRejected description: 'Broken Promise not rejected'.
> -        self assert: p error = 1.
> -        self assert: q error == error.!
>
> Item was changed:
>   ----- Method: PromiseTest>>testAnErrorInThenRejectsPromise (in category 'tests - monad') -----
>   testAnErrorInThenRejectsPromise
> +        | p q |
> -        "https://promisesaplus.com section 2.2.7.2"
> -        | p q error |
>          p := Promise new.
> +        q := p then: [:v | KeyNotFound signal].
> -        q := p then: [:v | (error := KeyNotFound new) signal].
>          p resolveWith: 1.
>          self deny: p isRejected description: 'Original Promise rejected'.
> +        self assert: q isRejected description: 'Broken Promise not rejected'.!
> -        self assert: q isRejected description: 'Broken Promise not rejected'.
> -        self assert: p value = 1.
> -        self assert: q error == error.!
>
> Item was removed:
> - ----- Method: PromiseTest>>testNilErrBlockPropagation (in category 'tests - monad') -----
> - testNilErrBlockPropagation
> -        "https://promisesaplus.com section 2.2.7.4"
> -        | p q |
> -        p := Promise new.
> -        q := p then: [:v | self error: 'Shouldn''t call resolvedBlock'] ifRejected: nil.
> -        p rejectWith: 1.
> -        self assert: p isRejected.
> -        self assert: q isRejected.
> -        self assert: p error equals: 1.
> -        self assert: q error equals: 1.!
>
> Item was removed:
> - ----- Method: PromiseTest>>testNilResolvedBlockPropagation (in category 'tests - monad') -----
> - testNilResolvedBlockPropagation
> -        "https://promisesaplus.com section 2.2.7.3"
> -        | p q |
> -        p := Promise new.
> -        q := p then: nil ifRejected: [:e | self error: 'Shouldn''t call errBlock'].
> -        p resolveWith: 1.
> -        self assert: p isResolved.
> -        self assert: q isResolved.
> -        self assert: p value equals: 1.
> -        self assert: q value equals: 1.!
>
> Item was changed:
>   ----- Method: PromiseTest>>testifRejectedRunsBlockIfPromiseFails (in category 'tests - monad') -----
>   testifRejectedRunsBlockIfPromiseFails
> -        "https://promisesaplus.com section 2.2.7.1"
>          | p q error |
>          error := nil.
>          p := Promise new.
> +        q := p ifRejected: [:e | error := e].
> -        q := p ifRejected: [:e | error := e "N.B. returns a value, does not signal an Exception"].
>          p rejectWith: KeyNotFound new.
> +        self assert: q isRejected.
> +        self assert: KeyNotFound equals: error class.!
> -        self assert: q isResolved.
> -        self assert: KeyNotFound equals: error class.
> -        self assert: q value == error.!
>
> Item was removed:
> - Object subclass: #WriteBarrierAnotherStub
> -        instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
> -        classVariableNames: ''
> -        poolDictionaries: ''
> -        category: 'KernelTests-WriteBarrier'!
>
> Item was removed:
> - ----- Method: WriteBarrierAnotherStub>>var1 (in category 'accessing') -----
> - var1
> -        ^ var1!
>
> Item was removed:
> - ----- Method: WriteBarrierAnotherStub>>var10 (in category 'accessing') -----
> - var10
> -        ^ var10!
>
> Item was removed:
> - ----- Method: WriteBarrierAnotherStub>>var10: (in category 'accessing') -----
> - var10: anObject
> -        var10 := anObject!
>
> Item was removed:
> - ----- Method: WriteBarrierAnotherStub>>var1: (in category 'accessing') -----
> - var1: anObject
> -        var1 := anObject!
>
> Item was removed:
> - Object subclass: #WriteBarrierStub
> -        instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10'
> -        classVariableNames: ''
> -        poolDictionaries: ''
> -        category: 'KernelTests-WriteBarrier'!
>
> Item was removed:
> - ----- Method: WriteBarrierStub>>var1 (in category 'accessing') -----
> - var1
> -        ^ var1!
>
> Item was removed:
> - ----- Method: WriteBarrierStub>>var10 (in category 'accessing') -----
> - var10
> -        ^ var10!
>
> Item was removed:
> - ----- Method: WriteBarrierStub>>var10: (in category 'accessing') -----
> - var10: anObject
> -        var10 := anObject!
>
> Item was removed:
> - ----- Method: WriteBarrierStub>>var1: (in category 'accessing') -----
> - var1: anObject
> -        var1 := anObject!
>
> Item was removed:
> - 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 removed:
> - ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') -----
> - initialize
> -       
> -        ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()!
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>alwaysReadOnlyObjects (in category 'guinea pigs') -----
> - alwaysReadOnlyObjects
> -        "Immediates are always immutable"
> -        ^ { 1 }!
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>alwaysWritableObjects (in category 'guinea pigs') -----
> - alwaysWritableObjects
> -        "Objects that currently can't be immutable"
> -        ^ { ContextInstance .
> -                Processor .
> -                Processor activeProcess }!
>
> Item was removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') -----
> - testBasicProxyReadOnly
> -        self alwaysReadOnlyObjects do: [ :each |
> -                self assert: (MirrorPrimitives isObjectReadOnly: each) equals: true ]!
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>testBasicProxyWritable (in category 'tests - proxy') -----
> - testBasicProxyWritable
> -        self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
> -                self assert: (MirrorPrimitives isObjectReadOnly: each) equals: false ]!
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>testBasicReadOnly (in category 'tests - object') -----
> - testBasicReadOnly
> -        self alwaysReadOnlyObjects do: [ :each |
> -                self assert: each isReadOnlyObject equals: true ]!
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>testBasicWritable (in category 'tests - object') -----
> - testBasicWritable
> -        self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each |
> -                self assert: each isReadOnlyObject equals: false ]!
>
> Item was removed:
> - ----- 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 removed:
> - ----- 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!
>
> Item was removed:
> - ----- 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!
>
> Item was removed:
> - ----- 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!
>
> Item was removed:
> - ----- 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!
>
> Item was removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- 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!
>
> Item was removed:
> - ----- 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 removed:
> - ----- 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 removed:
> - ----- 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
> - !
>
> Item was removed:
> - ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingBasicAtPut (in category 'tests - object') ---