| Newsgroups |
gmane.comp.lang.smalltalk.squeak.general |
| Message-ID |
<[email protected]> |
Christoph Thiede uploaded a new version of KernelTests to project The Trunk:
http://source.squeak.org/trunk/KernelTests-ct.376.mcz
==================== Summary ====================
Name: KernelTests-ct.376
Author: ct
Time: 27 January 2020, 1:08:37.013199 pm
UUID: 7ed66f25-b6e3-1743-a84c-d8a571a6d1e7
Ancestors: KernelTests-ct.375
Tests #contextEnsure: and #contextOn:do:. Includes regression tests for Kernel-ct.1296.
=============== Diff against KernelTests-nice.373 ===============
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>>simulate: (in category 'private') -----
+ simulate: aBlock
+
+ | result |
+ [result := aBlock value] newProcess runUntil: [:ctxt | false].
+ ^ result!
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>>testContextEnsure (in category 'tests') -----
+ testContextEnsure
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextEnsure: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0].
+
+ result := block value.
+ self assert: 0 equals: result.
+ self assert: 1 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextEnsureSimulation (in category 'tests') -----
+ testContextEnsureSimulation
+ "Regression test for http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html"
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextEnsure: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0].
+
+ self shouldnt: [result := self simulate: block] raise: Error. "this wrapper is important for avoiding a debugger chain when testing"
+ self assert: 0 equals: result.
+ self assert: 1 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextEnsureSimulationWithError (in category 'tests') -----
+ testContextEnsureSimulationWithError
+ "Regression test for http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html"
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextEnsure: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0.
+ self error].
+
+ self
+ shouldnt: [result := self simulate: [[block value] on: Error do: [42]]]
+ raise: Error. "this wrapper is important for avoiding a debugger chain when testing"
+ self assert: 42 equals: result.
+ self assert: 1 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextEnsureWithError (in category 'tests') -----
+ testContextEnsureWithError
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextEnsure: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0.
+ self error].
+
+ result := [block value] on: Error do: [42].
+ self assert: 42 equals: result.
+ self assert: 1 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextOnDo (in category 'tests') -----
+ testContextOnDo
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextOn: Error do: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0].
+
+ result := block value.
+ self assert: 0 equals: result.
+ self assert: 0 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextOnDoSimulation (in category 'tests') -----
+ testContextOnDoSimulation
+ "Regression test for http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html"
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextOn: Error do: [
+ sideEffect := sideEffect + 1]).
+ sideEffect := 0].
+
+ self shouldnt: [result := self simulate: block] raise: Error. "this wrapper is important for avoiding a debugger chain when testing"
+ self assert: 0 equals: result.
+ self assert: 0 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextOnDoSimulationWithError (in category 'tests') -----
+ testContextOnDoSimulationWithError
+ "Regression test for http://forum.world.st/BUG-s-in-Context-control-jump-runUntilErrorOrReturnFrom-td5107263.html"
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextOn: Error do: [
+ sideEffect := sideEffect + 1.
+ 42]).
+ sideEffect := 0.
+ self error].
+
+ self shouldnt: [result := self simulate: block] raise: Error. "this wrapper is important for avoiding a debugger chain when testing"
+ self assert: 42 equals: result.
+ self assert: 1 equals: sideEffect.!
Item was added:
+ ----- Method: ContextTest>>testContextOnDoWithError (in category 'tests') -----
+ testContextOnDoWithError
+
+ | sideEffect block result |
+ block := [
+ sideEffect := nil. "if the ensure block would be evaluated too early, this would raise an error"
+ thisContext insertSender: (
+ Context contextOn: Error do: [
+ sideEffect := sideEffect + 1.
+ 42]).
+ sideEffect := 0.
+ self error].
+
+ result := block value.
+ self assert: 42 equals: result.
+ self assert: 1 equals: sideEffect.!
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>>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@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>>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'.
- !
Squeak-dev mailing list -- [email protected]
To unsubscribe send an email to [email protected]