[squeak-dev] The Trunk: KernelTests-eem.396.mczcommits at source.squeak.org commits at source.squeak.orgMon Apr 12 18:30:55 UTC 2021
Eliot Miranda uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-eem.396.mcz ==================== Summary ==================== Name: KernelTests-eem.396 Author: eem Time: 12 April 2021, 11:30:53.654392 am UUID: 642cd275-3ce5-4cfb-a34f-1bb29d140e94 Ancestors: KernelTests-codefrau.395 Rename MethodContextTest to ContextTest =============== Diff against KernelTests-codefrau.395 =============== 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 at 100 corner: 200 at 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 at 100 corner: 200 at 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>>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 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" + {}. "missing selector" + {#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: (Context runSimulated: [nil tryPrimitive: 100 withArgs: args]) + equals: (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" + {}. "missing selector" + {#isNil. 'excess arg'}. "too many arguments" + {#=}. "missing argument" + } do: [:args | + self + assert: (Context runSimulated: [nil tryPrimitive: 83 withArgs: args]) + equals: (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" + {}. "missing selector" + {#isNil}. "missing arguments" + {#isNil. 'not an array'}. "invalid arguments" + {#isNil. {'excess arg'}}. "too many arguments" + {#=. {}}. "missing argument" + } do: [:args | + self + assert: (Context runSimulated: [nil tryPrimitive: 84 withArgs: args]) + equals: (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: - 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 at 100 corner: 200 at 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 at 100 corner: 200 at 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'. - !
More information about the Squeak-dev mailing list |