From e0c94c174fc0af79b671b1fa2e3f16d095f5812b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:04:53 -0300 Subject: [PATCH 01/11] [SUnit] add module and tests --- modules/SUnit/CharacterArray.st | 22 + modules/SUnit/Class.st | 12 + modules/SUnit/Closure.st | 44 + modules/SUnit/CompiledExpression.st | 12 + modules/SUnit/CompiledMethod.st | 12 + modules/SUnit/Exception.st | 24 + modules/SUnit/ExceptionHandler.st | 12 + modules/SUnit/Object.st | 22 + modules/SUnit/SUnitModule.st | 26 + modules/SUnit/SUnitNameResolver.st | 38 + modules/SUnit/Species.st | 47 + modules/SUnit/Symbol.st | 12 + modules/SUnit/TestCase.st | 809 ++++++++++++++++++ modules/SUnit/TestCounter.st | 65 ++ modules/SUnit/TestFailure.st | 29 + modules/SUnit/TestResource.st | 134 +++ modules/SUnit/TestResult.st | 375 ++++++++ modules/SUnit/TestSkipped.st | 16 + modules/SUnit/TestSuite.st | 285 ++++++ modules/SUnit/Tests/ExampleSetTest.st | 64 ++ .../Tests/ResumableTestFailureTestCase.st | 67 ++ modules/SUnit/Tests/SUnitTest.st | 301 +++++++ modules/SUnit/Tests/SimpleTestResource.st | 67 ++ .../SUnit/Tests/SimpleTestResourceTestCase.st | 72 ++ modules/SUnit/Tests/TestsModule.st | 29 + 25 files changed, 2596 insertions(+) create mode 100644 modules/SUnit/CharacterArray.st create mode 100644 modules/SUnit/Class.st create mode 100644 modules/SUnit/Closure.st create mode 100644 modules/SUnit/CompiledExpression.st create mode 100644 modules/SUnit/CompiledMethod.st create mode 100644 modules/SUnit/Exception.st create mode 100644 modules/SUnit/ExceptionHandler.st create mode 100644 modules/SUnit/Object.st create mode 100644 modules/SUnit/SUnitModule.st create mode 100644 modules/SUnit/SUnitNameResolver.st create mode 100644 modules/SUnit/Species.st create mode 100644 modules/SUnit/Symbol.st create mode 100644 modules/SUnit/TestCase.st create mode 100644 modules/SUnit/TestCounter.st create mode 100644 modules/SUnit/TestFailure.st create mode 100644 modules/SUnit/TestResource.st create mode 100644 modules/SUnit/TestResult.st create mode 100644 modules/SUnit/TestSkipped.st create mode 100644 modules/SUnit/TestSuite.st create mode 100644 modules/SUnit/Tests/ExampleSetTest.st create mode 100644 modules/SUnit/Tests/ResumableTestFailureTestCase.st create mode 100644 modules/SUnit/Tests/SUnitTest.st create mode 100644 modules/SUnit/Tests/SimpleTestResource.st create mode 100644 modules/SUnit/Tests/SimpleTestResourceTestCase.st create mode 100644 modules/SUnit/Tests/TestsModule.st diff --git a/modules/SUnit/CharacterArray.st b/modules/SUnit/CharacterArray.st new file mode 100644 index 0000000..72f0845 --- /dev/null +++ b/modules/SUnit/CharacterArray.st @@ -0,0 +1,22 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #CharacterArray } + +{ #category : '*SUnit' } +CharacterArray >> sunitAsSymbol [ + ^self asSymbol +] + +{ #category : '*SUnit' } +CharacterArray >> sunitMatch: aString [ + "Answer if there is a match starting at 1" + | n | + n := self size. + aString size < n ifTrue: [^false]. + 1 to: n do: [:i | (self at: i) == (aString at: i) ifFalse: [^false]]. + ^true. +] + diff --git a/modules/SUnit/Class.st b/modules/SUnit/Class.st new file mode 100644 index 0000000..a4c7495 --- /dev/null +++ b/modules/SUnit/Class.st @@ -0,0 +1,12 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Class } + +{ #category : '*SUnit' } +Class >> sunitName [ + ^self name asSymbol +] + diff --git a/modules/SUnit/Closure.st b/modules/SUnit/Closure.st new file mode 100644 index 0000000..ffb746d --- /dev/null +++ b/modules/SUnit/Closure.st @@ -0,0 +1,44 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Closure } + +{ #category : '*SUnit' } +Closure >> sunitEnsure: terminationBlock [ + ^self ensure: terminationBlock +] + +{ #category : '*SUnit' } +Closure >> sunitOn: exception do: handlerBlock [ + ^self on: exception do: handlerBlock +] + +{ #category : '*SUnit' } +Closure >> sunitOn: exception1 +do: handlerBlock1 +on: exception2 +do: handlerBlock2 [ + ^self sunitOn: exception1 , exception2 do: [:ex | + (ex isKindOf: exception1) + ifTrue: [handlerBlock1 evaluateWith: ex] + ifFalse: [handlerBlock2 evaluateWith: ex]] +] + +{ #category : '*SUnit' } +Closure >> sunitOn: exception1 +do: handlerBlock1 +on: exception2 +do: handlerBlock2 +on: exception3 +do: handlerBlock3 [ + ^self sunitOn: exception1 , exception2 , exception3 do: [:exception | + (exception isKindOf: exception1) + ifTrue: [handlerBlock1 evaluateWith: exception] + ifFalse: [ + (exception isKindOf: exception2) + ifTrue: [handlerBlock2 evaluateWith: exception] + ifFalse: [handlerBlock3 evaluateWith: exception]]] +] + diff --git a/modules/SUnit/CompiledExpression.st b/modules/SUnit/CompiledExpression.st new file mode 100644 index 0000000..5e9c8b9 --- /dev/null +++ b/modules/SUnit/CompiledExpression.st @@ -0,0 +1,12 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #CompiledExpression } + +{ #category : '*SUnit' } +CompiledExpression >> isTest [ + ^false +] + diff --git a/modules/SUnit/CompiledMethod.st b/modules/SUnit/CompiledMethod.st new file mode 100644 index 0000000..0f35e07 --- /dev/null +++ b/modules/SUnit/CompiledMethod.st @@ -0,0 +1,12 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #CompiledMethod } + +{ #category : '*SUnit' } +CompiledMethod >> isTest [ + ^(class inheritsFrom: TestCase) and: [class isTestSelector: selector] +] + diff --git a/modules/SUnit/Exception.st b/modules/SUnit/Exception.st new file mode 100644 index 0000000..83ec3b7 --- /dev/null +++ b/modules/SUnit/Exception.st @@ -0,0 +1,24 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Exception } + +{ #category : '*SUnit' } +Exception class >> sunitSignalWith: aString [ + self signal: aString +] + +{ #category : '*SUnit' } +Exception >> hasNextHandler [ + | next | + next := self nextHandler. + ^next notNil andNot: [next isSUnitHandler] +] + +{ #category : '*SUnit' } +Exception >> sunitExitWith: aValue [ + self return: aValue +] + diff --git a/modules/SUnit/ExceptionHandler.st b/modules/SUnit/ExceptionHandler.st new file mode 100644 index 0000000..3db8257 --- /dev/null +++ b/modules/SUnit/ExceptionHandler.st @@ -0,0 +1,12 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #ExceptionHandler } + +{ #category : '*SUnit' } +ExceptionHandler >> isSUnitHandler [ + ^handlerBlock method selector beginsWith: 'sunit' +] + diff --git a/modules/SUnit/Object.st b/modules/SUnit/Object.st new file mode 100644 index 0000000..1c3b120 --- /dev/null +++ b/modules/SUnit/Object.st @@ -0,0 +1,22 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Object } + +{ #category : '*SUnit' } +Object >> sunitAddDependent: anObject [ + self addDependent: anObject +] + +{ #category : '*SUnit' } +Object >> sunitChanged: aspect [ + self changed: aspect +] + +{ #category : '*SUnit' } +Object >> sunitRemoveDependent: anObject [ + self removeDependent: anObject +] + diff --git a/modules/SUnit/SUnitModule.st b/modules/SUnit/SUnitModule.st new file mode 100644 index 0000000..68fe3d5 --- /dev/null +++ b/modules/SUnit/SUnitModule.st @@ -0,0 +1,26 @@ +Class { + #name : #SUnitModule, + #superclass : #Module, + #instVars : [ + 'random' + ], + #category : #SUnit +} + +{ #category : #spec } +SUnitModule >> imports [ + ^{ + #Kernel -> #(Bag CharacterArray Class Closure CompiledExpression CompiledMethod Error Exception ExceptionHandler IdentitySet Notification Species Symbol). + #Random -> #(Random) + } +] + +{ #category : #spec } +SUnitModule >> initialize [ + super initialize. +] + +{ #category : #accessing } +SUnitModule >> random [ + ^random ifNil: [ random := Random new] +] diff --git a/modules/SUnit/SUnitNameResolver.st b/modules/SUnit/SUnitNameResolver.st new file mode 100644 index 0000000..c4d7606 --- /dev/null +++ b/modules/SUnit/SUnitNameResolver.st @@ -0,0 +1,38 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #SUnitNameResolver, + #superclass : #Object, + #category : #SUnit +} + +{ #category : #unclassified } +SUnitNameResolver class >> classNamed: aSymbol [ + ^Smalltalk + at: aSymbol + ifAbsent: [nil] +] + +{ #category : #unclassified } +SUnitNameResolver class >> defaultLogDevice [ + ^Transcript +] + +{ #category : #unclassified } +SUnitNameResolver class >> errorObject [ + ^Error +] + +{ #category : #unclassified } +SUnitNameResolver class >> mnuExceptionObject [ + ^MessageNotUnderstood +] + +{ #category : #unclassified } +SUnitNameResolver class >> notificationObject [ + ^Notification +] + diff --git a/modules/SUnit/Species.st b/modules/SUnit/Species.st new file mode 100644 index 0000000..4898014 --- /dev/null +++ b/modules/SUnit/Species.st @@ -0,0 +1,47 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Species } + +{ #category : '*SUnit' } +Species >> selectorsUpTo: aClass [ + | cls | + ^Array streamContents: [:strm | + cls := self. + [ + cls notNil + ifTrue: [cls methodDictionary keysAndValuesDo: [:k :v | strm nextPut: k]]. + cls == aClass] + whileFalse: [cls := cls superclass]] +] + +{ #category : '*SUnit' } +Species >> selectorsUpTo: aClass satisfying: aBlock [ + | cls set | + set := IdentitySet new: 100. + cls := self. + [ + cls notNil ifTrue: [ + cls methodDictionary + keysAndValuesDo: [:k :v | (aBlock value: k) ifTrue: [set add: k]]]. + cls == aClass] + whileFalse: [cls := cls superclass]. + ^set +] + +{ #category : '*SUnit' } +Species >> sunitAllSelectors [ + | answer | + answer := self superclass == Object + ifTrue: [self selectors] + ifFalse: [self superclass sunitAllSelectors addAll: self selectors; yourself]. + ^answer asOrderedCollection +] + +{ #category : '*SUnit' } +Species >> sunitSelectors [ + ^self selectors asOrderedCollection sort +] + diff --git a/modules/SUnit/Symbol.st b/modules/SUnit/Symbol.st new file mode 100644 index 0000000..8fe5c3d --- /dev/null +++ b/modules/SUnit/Symbol.st @@ -0,0 +1,12 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Extension { #name : #Symbol } + +{ #category : '*SUnit' } +Symbol >> sunitAsClass [ + ^SUnitNameResolver classNamed: self +] + diff --git a/modules/SUnit/TestCase.st b/modules/SUnit/TestCase.st new file mode 100644 index 0000000..a6af687 --- /dev/null +++ b/modules/SUnit/TestCase.st @@ -0,0 +1,809 @@ +" + Copyright (c) 2021-2025 Aucerna, Javier Pimás. + See (MIT) license in root directory. +" + +Class { + #name : #TestCase, + #superclass : #Object, + #instVars : [ + 'testSelector', + 'testSeed', + 'time', + 'counter' + ], + #category : #SUnit +} + +{ #category : #running } +TestCase class >> allTestSelectors [ + ^(self + selectorsUpTo: self rootClass + satisfying: [:selector | self isTestSelector: selector]) asOrderedCollection sort +] + +{ #category : #running } +TestCase class >> buildSuiteFromAllSelectors [ + ^self buildSuiteFromMethods: self allTestSelectors +] + +{ #category : #running } +TestCase class >> buildSuiteFromLocalSelectors [ + ^self buildSuiteFromMethods: self testSelectors +] + +{ #category : #running } +TestCase class >> buildSuiteFromMethods: aCollection [ + | suite | + suite := self newSuite. + self shouldBuildForSubclasses + ifTrue: [ + self allSubclasses reject: #shouldIgnoreTestClass thenDo: [:c | | s | + s := c buildSuiteFromMethods: aCollection. + suite addTest: s]] + ifFalse: [ + aCollection do: [:selector | | test | + test := self selector: selector. + suite addTest: test]]. + ^suite +] + +{ #category : #running } +TestCase class >> buildSuiteFromSelectors [ + self shouldIgnoreTestClass ifTrue: [^self newSuite]. + ^self shouldInheritSelectors + ifTrue: [self buildSuiteFromAllSelectors] + ifFalse: [self buildSuiteFromLocalSelectors] +] + +{ #category : #running } +TestCase class >> buildTestSuite [ + | suite | + ^self isAbstract + ifTrue: [ + suite := self newSuite. + self allSubclasses + do: [:cls | cls isAbstract + ifFalse: [suite addTest: cls buildSuiteFromSelectors]]. + suite] + ifFalse: [self buildSuiteFromSelectors] +] + +{ #category : #testing } +TestCase class >> debug: aSymbol [ + ^(self selector: aSymbol) debug +] + +{ #category : #testing } +TestCase class >> isAbstract [ + ^self sunitName = #TestCase +] + +{ #category : #testing } +TestCase class >> isTestSelector: aSymbol [ + aSymbol == #tests ifTrue: [^false]. + ^(self selectorPatterns + anySatisfy: [:pattern | pattern sunitMatch: aSymbol]) + and: [aSymbol last != $:] +] + +{ #category : #running } +TestCase class >> newSuite [ + ^self suiteClass named: self name asString +] + +{ #category : #resources } +TestCase class >> resources [ + ^#() +] + +{ #category : #accessing } +TestCase class >> rootClass [ + ^TestCase +] + +{ #category : #running } +TestCase class >> run: aSymbol [ + ^(self selector: aSymbol) run +] + +{ #category : #initialization } +TestCase class >> selector: aSymbol [ + ^self new testSelector: aSymbol +] + +{ #category : #running } +TestCase class >> selectorPattern [ + ^'test' +] + +{ #category : #running } +TestCase class >> selectorPatterns [ + ^#('test' 'devTest') +] + +{ #category : #running } +TestCase class >> shouldBuildForSubclasses [ + ^self isAbstract +] + +{ #category : #testing } +TestCase class >> shouldIgnoreTestClass [ + ^self isAbstract +] + +{ #category : #testing } +TestCase class >> shouldInheritSelectors [ + ^self superclass isAbstract or: [self testSelectors isEmpty] +] + +{ #category : #running } +TestCase class >> suite [ + ^self buildTestSuite +] + +{ #category : #running } +TestCase class >> suiteClass [ + ^TestSuite + +] + +{ #category : #accessing } +TestCase class >> sunitVersion [ + ^'3.1' + +] + +{ #category : #running } +TestCase class >> testSelectors [ + ^self sunitSelectors select: [:each | + (self selectorPatterns anySatisfy: [:pattern | pattern sunitMatch: each]) + and: [each last ~= $:]] +] + +{ #category : #accessing } +TestCase >> addCountTo: aTestCounter [ + aTestCounter addCounter: counter] + +{ #category : #compatibility } +TestCase >> addDependentToHierachy: anObject [ + "an empty method. for Composite compability with TestSuite" +] + +{ #category : #compatibility } +TestCase >> addDependentToHierarchy: anObject [ + "an empty method. for Composite compability with TestSuite" +] + +{ #category : #accessing } +TestCase >> allCases [ + ^{self} +] + +{ #category : #accessing } +TestCase >> anyTest [ + ^self +] + +{ #category : #asserting } +TestCase >> assert: aBoolean [ + self count: #assert:; primAssert: aBoolean +] + +{ #category : #asserting } +TestCase >> assert: aBoolean description: aString [ + self + count: #assert:description:; + primAssert: aBoolean description: aString +] + +{ #category : #asserting } +TestCase >> assert: aBoolean description: aString resumable: resumableBoolean [ + self + count: #assert:description:resumable:; + primAssert: aBoolean description: aString resumable: resumableBoolean +] + +{ #category : #unclassified } +TestCase >> assert: result equals: expected [ + self assert: result = expected +] + +{ #category : #running } +TestCase >> basicRun: aTestResult [ + (aTestResult skipped includes: self) ifFalse: [aTestResult runCase: self] +] + +{ #category : #exceptions } +TestCase >> caseCount [ + ^1 +] + +{ #category : #accessing } +TestCase >> checkDescriptions [ + ^counter checkDescriptions +] + +{ #category : #accessing } +TestCase >> count: selector [ + counter count: selector +] + +{ #category : #accessing } +TestCase >> currentTest [ + ^self +] + +{ #category : #debugging } +TestCase >> debug [ + self resources do: [:resource | resource beAvailableFor: self]. + [(self class selector: testSelector) runCase] + sunitEnsure: [self resources do: [:resource | resource reset]] +] + +{ #category : #debugging } +TestCase >> debugAsFailure [ + | semaphore | + semaphore := Semaphore new. + self resources do: [:resource | resource beAvailableFor: self]. + [ + semaphore wait. + self resources do: [:resource | resource reset]] fork. + ^false + ifTrue: [(self class selector: testSelector) runCaseAsFailure: semaphore] + ifFalse: [self runCaseAsFailure: semaphore] +] + +{ #category : #denying } +TestCase >> deny: aBoolean [ + self count: #deny:; primDeny: aBoolean +] + +{ #category : #denying } +TestCase >> deny: aBoolean description: aString [ + self + count: #deny:description:; + primDeny: aBoolean description: aString +] + +{ #category : #denying } +TestCase >> deny: aBoolean description: aString resumable: resumableBoolean [ + self + count: #deny:description:resumable:; + primDeny: aBoolean description: aString resumable: resumableBoolean +] + +{ #category : #exceptions } +TestCase >> executeShould: aBlock inScopeOf: anExceptionalEvent [ + ^[ + aBlock value. + false] + sunitOn: anExceptionalEvent + do: [:ex | ex return: true] +] + +{ #category : #exceptions } +TestCase >> executeShould: aBlock inScopeOf: anExceptionalEvent checking: exceptionBlock [ + ^[ + aBlock value. + false] + sunitOn: anExceptionalEvent + do: [:ex | ex return: (exceptionBlock value: ex)] +] + +{ #category : #logging } +TestCase >> failureLog [ + "dialect-specific" + "VA - System errorLog" + "VW, Dolphin - Transcript" + + ^SUnitNameResolver defaultLogDevice +] + +{ #category : #accessing } +TestCase >> get: aspect from: anObject [ + ^anObject instVarNamed: aspect asString +] + +{ #category : #accessing } +TestCase >> importFrom: data [ + testSeed := data at: 4. + time := data at: 5. + counter := data at: 6 +] + +{ #category : #initialization } +TestCase >> initialize [ + testSeed := self random seed. + counter := TestCounter new +] + +{ #category : #testing } +TestCase >> isKnownIssue [ + | cm | + cm := self methodFor: testSelector. + ^cm notNil and: [cm includesIdentical: #knownIssue] +] + +{ #category : #comparing } +TestCase >> isLike: aTestCase [ + aTestCase class == self class ifFalse: [^false]. + ^aTestCase selector = self selector +] + +{ #category : #testing } +TestCase >> isLogging [ + "By default, we're not logging failures. If you override this in + a subclass, make sure that you override #failureLog" + ^false +] + +{ #category : #testing } +TestCase >> isSlow [ + | cm | + cm := self methodFor: testSelector. + ^cm notNil and: [cm includesIdentical: #slowTest] +] + +{ #category : #logging } +TestCase >> logFailure: aString [ + self isLogging ifTrue: [ + self failureLog + cr; + nextPutAll: aString; + flush] +] + +{ #category : #debugging } +TestCase >> openDebuggerOnFailingTestMethod [ + "SUnit has halted one step in front of the failing test method. Step over the + 'self halt' and send into 'self perform: testSelector' to see the failure from + the beginning" + self performTest +] + +{ #category : #running } +TestCase >> performTest [ + self perform: testSelector sunitAsSymbol +] + +{ #category : #asserting } +TestCase >> precondition: aBoolean [ + self assert: aBoolean description: 'Precondition for this test is not met' +] + +{ #category : #asserting } +TestCase >> primAssert: aBoolean [ + self primAssert: aBoolean description: 'Assertion failed' +] + +{ #category : #asserting } +TestCase >> primAssert: aBoolean description: aString [ + | msg | + aBoolean ifFalse: [ + msg := aString. + self isKnownIssue ifTrue: [msg := msg , ' - Known Issue']. + self logFailure: msg. + self signalFailure: msg] +] + +{ #category : #asserting } +TestCase >> primAssert: aBoolean description: aString resumable: rBoolean [ + aBoolean ifFalse: [ + self logFailure: aString. + TestResult failure sunitSignalWith: aString resumable: rBoolean] +] + +{ #category : #denying } +TestCase >> primDeny: aBoolean [ + self primAssert: aBoolean not +] + +{ #category : #denying } +TestCase >> primDeny: aBoolean description: aString [ + self primAssert: aBoolean not description: aString +] + +{ #category : #denying } +TestCase >> primDeny: aBoolean description: aString resumable: resumableBoolean [ + self + primAssert: aBoolean not + description: aString + resumable: resumableBoolean +] + +{ #category : #printing } +TestCase >> printOn: aStream [ + + aStream + nextPutAll: self class printString; + nextPutAll: '>>#'; + nextPutAll: testSelector asString + +] + +{ #category : #accessing } +TestCase >> random [ + ^TestCase module random +] + +{ #category : #accessing } +TestCase >> removeAllSuchThat: aBlock [ + ^self +] + +{ #category : #compatibility } +TestCase >> removeDependentFromHierachy: anObject [ + "an empty method. for Composite compability with TestSuite" +] + +{ #category : #compatibility } +TestCase >> removeDependentFromHierarchy: anObject [ + "an empty method. for Composite compability with TestSuite" +] + +{ #category : #accessing } +TestCase >> resources [ + | all queue r | + r := self class resources. + r isEmpty ifTrue: [^r]. + all := Set new. + queue := OrderedCollection new. + queue addAll: r. + [queue isEmpty] whileFalse: [| next | + next := queue removeFirst. + all add: next. + queue addAll: next resources]. + ^all +] + +{ #category : #running } +TestCase >> run [ + | result | + result := TestResult new. + self run: result. + ^result +] + +{ #category : #running } +TestCase >> run: aTestResult [ + aTestResult runCase: self +] + +{ #category : #running } +TestCase >> runCase [ + | t | + [ + t := Kernel host currentMilliseconds. + self initialize; setUp; performTest] + sunitEnsure: [self tearDown; time: Kernel host currentMilliseconds - t] +] + +{ #category : #running } +TestCase >> runCaseAsFailure: aSemaphore [ + [self setUp; openDebuggerOnFailingTestMethod] sunitEnsure: [ + self tearDown. + aSemaphore signal] +] + +{ #category : #accessing } +TestCase >> seed [ + ^testSeed +] + +{ #category : #accessing } +TestCase >> selector [ + ^testSelector isMessage + ifTrue: [testSelector selector] + ifFalse: [testSelector] +] + +{ #category : #accessing } +TestCase >> set: aspect of: anObject to: value [ + anObject instVarNamed: aspect asString put: value +] + +{ #category : #'set up' } +TestCase >> setUp [ + | file | + self random seed: testSeed. + counter reset +] + +{ #category : #asserting } +TestCase >> should: aBlock [ + self count: #should:. + self primAssert: aBlock value +] + +{ #category : #asserting } +TestCase >> should: aBlock description: aString [ + self count: #should:description:. + self primAssert: aBlock value description: aString +] + +{ #category : #asserting } +TestCase >> should: aBlock raise: anExceptionalEvent [ + self count: #should:raise:. + ^self primAssert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) +] + +{ #category : #asserting } +TestCase >> should: aBlock raise: anExceptionalEvent description: aString [ + self count: #should:raise:description:. + ^self + primAssert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) + description: aString +] + +{ #category : #asserting } +TestCase >> should: aBlock +raise: anExceptionalEvent +description: aString +resumable: aBoolean [ + | raised | + self count: #should:raise:description:. + raised := false. + [ + aBlock value. + false] + sunitOn: anExceptionalEvent + do: [:ex | + raised := true. + ex isResumable ifTrue: [ex resume] ifFalse: [ex return]]. + ^self + primAssert: raised + description: aString + resumable: aBoolean +] + +{ #category : #asserting } +TestCase >> should: aBlock raise: anExceptionalEvent satisfying: exceptionBlock [ + self count: #should:raise:. + ^self + primAssert: (self + executeShould: aBlock + inScopeOf: anExceptionalEvent + checking: exceptionBlock) +] + +{ #category : #asserting } +TestCase >> should: aBlock +raise: anExceptionalEvent +satisfying: exceptionBlock +description: aString [ + self count: #should:raise:description:. + ^self + primAssert: (self + executeShould: aBlock + inScopeOf: anExceptionalEvent + checking: exceptionBlock) + description: aString +] + +{ #category : #asserting } +TestCase >> should: aBlock send: aSymbol to: anObject [ + ^self + should: aBlock + send: aSymbol + to: anObject + description: aSymbol , ' should have been sent' +] + +{ #category : #asserting } +TestCase >> should: aBlock +send: aSymbol +to: anObject +description: aString [ + | sent | + sent := false. + anObject whenReceiving: aSymbol evaluate: [:msg | sent := true]. + aBlock ensure: [anObject stopSpying: aSymbol]. + self assert: sent description: aString +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock [ + self count: #shouldnt:; primDeny: aBlock value +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock description: aString [ + self + count: #shouldnt:description:; + primDeny: aBlock value description: aString +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock raise: anExceptionalEvent [ + ^self + count: #shouldnt:raise:; + primDeny: (self executeShould: aBlock inScopeOf: anExceptionalEvent) +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock raise: anExceptionalEvent description: aString [ + ^self + count: #shouldnt:raise:description:; + primDeny: (self executeShould: aBlock inScopeOf: anExceptionalEvent) + description: aString +] + +{ #category : #denying } +TestCase >> shouldnt: testBlock +raise: anExceptionalEvent +description: aString +ensure: aBlock [ + ^[self shouldnt: testBlock raise: anExceptionalEvent description: aString] + ensure: aBlock +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock +raise: anExceptionalEvent +description: aString +resumable: aBoolean [ + ^self + count: #shouldnt:raise:description:; + primDeny: (self executeShould: aBlock inScopeOf: anExceptionalEvent) + description: aString + resumable: aBoolean +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock raise: anExceptionalEvent otherwise: exceptionBlock [ + ^self + count: #shouldnt:raise:; + primDeny: (self + executeShould: aBlock + inScopeOf: anExceptionalEvent + checking: exceptionBlock) +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock +raise: anExceptionalEvent +satisfying: exceptionBlock +description: aString [ + self count: #shouldnt:raise:description:. + ^self + primDeny: (self + executeShould: aBlock + inScopeOf: anExceptionalEvent + checking: exceptionBlock) + description: aString +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock +send: aSymbol +moreThan: anInteger +timesTo: anObject [ + self + shouldnt: aBlock + send: aSymbol + moreThan: anInteger + timesTo: anObject + description: 'Possible stack overflow' +] + +{ #category : #denying } +TestCase >> shouldnt: aBlock +send: aSymbol +moreThan: anInteger +timesTo: anObject +description: aString [ + | count | + count := 0. + anObject whenReceiving: aSymbol evaluate: [:msg | + count := count + 1. + self assert: count <= anInteger description: aString]. + aBlock ensure: [anObject stopSpying: aSymbol] +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock send: aSymbol to: anObject [ + ^self + shouldnt: aBlock + send: aSymbol + to: anObject + description: aSymbol storeString , ' should not be sent to ' + , anObject printString +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock +send: aSymbol +to: anObject +description: aString [ + anObject + whenReceiving: aSymbol + evaluate: [:msg | self deny: true description: aString]. + aBlock ensure: [anObject stopSpying: aSymbol] +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock takeMoreThan: milliseconds [ + self + shouldnt: aBlock + takeMoreThan: milliseconds + description: 'Too long time to perform this task' +] + +{ #category : #asserting } +TestCase >> shouldnt: aBlock takeMoreThan: milliseconds description: aString [ + | semaphore process | + semaphore := Semaphore new. + process := [ + aBlock value. + semaphore signal] + forkAt: Processor userBackgroundPriority. + [semaphore waitForAtMost: milliseconds] on: Timeout do: [ + process terminate. + self assert: false print description: aString]. + self assert: true +] + +{ #category : #exceptions } +TestCase >> signalFailure: aString [ + TestResult failure sunitSignalWith: aString +] + +{ #category : #exceptions } +TestCase >> signalSkipped: aString [ + TestResult skipped sunitSignalWith: aString +] + +{ #category : #accessing } +TestCase >> signature [ + ^self suite name -> self class name -> testSelector +] + +{ #category : #skipping } +TestCase >> skipIf: aBoolean description: aString [ + aBoolean ifTrue: [self signalSkipped: aString] +] + +{ #category : #compatibility } +TestCase >> stop: aBoolean [ +] + +{ #category : #accessing } +TestCase >> suite [ + ^self propertyAt: #suite +] + +{ #category : #accessing } +TestCase >> suite: aTestSuite [ + self propertyAt: #suite put: aTestSuite +] + +{ #category : #running } +TestCase >> tearDown [ + +] + +{ #category : #accessing } +TestCase >> tests [ + ^{self} +] + +{ #category : #accessing } +TestCase >> testSelector: aSymbol [ + testSelector := aSymbol +] + +{ #category : #accessing } +TestCase >> time [ + ^time +] + +{ #category : #accessing } +TestCase >> time: anInteger [ + time := anInteger +] + +{ #category : #accessing } +TestCase >> totalChecks [ + ^counter totalChecks +] diff --git a/modules/SUnit/TestCounter.st b/modules/SUnit/TestCounter.st new file mode 100644 index 0000000..91efd38 --- /dev/null +++ b/modules/SUnit/TestCounter.st @@ -0,0 +1,65 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestCounter, + #superclass : #Object, + #instVars : [ + 'checks' + ], + #category : #SUnit +} + +{ #category : #accessing } +TestCounter >> addCounter: aTestCounter [ + checks addAll: aTestCounter checks +] + +{ #category : #printing } +TestCounter >> checkDescriptions [ + | description stream | + description := OrderedCollection new. + checks withOccurrencesDo: [:selector :total | + stream := '' writeStream. + stream + nextPutAll: ' > '; + print: selector; + space; + print: total. + description add: stream contents]. + ^description +] + +{ #category : #accessing } +TestCounter >> checks [ + ^checks +] + +{ #category : #accessing } +TestCounter >> count: aspect [ + checks add: aspect +] + +{ #category : #initialization } +TestCounter >> initialize [ + super initialize. + checks := Bag new +] + +{ #category : #inquiries } +TestCounter >> occurrencesOf: aSymbol [ + ^checks occurrencesOf: aSymbol +] + +{ #category : #accessing } +TestCounter >> reset [ + checks removeAll +] + +{ #category : #inquiries } +TestCounter >> totalChecks [ + ^checks size +] + diff --git a/modules/SUnit/TestFailure.st b/modules/SUnit/TestFailure.st new file mode 100644 index 0000000..741ba79 --- /dev/null +++ b/modules/SUnit/TestFailure.st @@ -0,0 +1,29 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestFailure, + #superclass : #Exception, + #instVars : [ + 'resumable' + ], + #category : #SUnit +} + +{ #category : #sunit } +TestFailure class >> sunitSignalWith: aString resumable: aBoolean [ + ^self new description: aString; resumable: aBoolean; signal +] + +{ #category : #testing } +TestFailure >> isResumable [ + ^resumable notNil and: [resumable] +] + +{ #category : #testing } +TestFailure >> resumable: aBoolean [ + resumable := aBoolean +] + diff --git a/modules/SUnit/TestResource.st b/modules/SUnit/TestResource.st new file mode 100644 index 0000000..df772bc --- /dev/null +++ b/modules/SUnit/TestResource.st @@ -0,0 +1,134 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestResource, + #superclass : #Object, + #instVars : [ + 'name', + 'description' + ], + #category : #SUnit +} + +{ #category : #'pm support' } +TestResource class >> aboutToSaveLibraryOn: aCodeSegmentBuilder [ + aCodeSegmentBuilder map: current to: nil +] + +{ #category : #testing } +TestResource class >> beAvailableFor: aTestSuite [ + ^self current notNil and: [self current beAvailableFor: aTestSuite] +] + +{ #category : #accessing } +TestResource class >> current [ + current isNil ifTrue: [current := self new]. + ^current +] + +{ #category : #accessing } +TestResource class >> current: aTestResource [ + current := aTestResource +] + +{ #category : #testing } +TestResource class >> isAbstract [ + "Override to true if a TestResource subclass is Abstract and should not have TestCase + instances built from it" + ^self name = 'TestResource' +] + +{ #category : #testing } +TestResource class >> isUnavailable [ + ^self isAvailable not +] + +{ #category : #accessing } +TestResource class >> reset [ + current notNil ifTrue: [[current tearDown] ensure: [current := nil]] +] + +{ #category : #accessing } +TestResource class >> resources [ + ^#() +] + +{ #category : #exceptions } +TestResource class >> signalInitializationError [ + ^TestResult + signalErrorWith: 'Resource ' , self name , ' could not be initialized' +] + +{ #category : #testing } +TestResource >> beAvailable [ + self isAvailable ifFalse: [self signalInitializationError] +] + +{ #category : #testing } +TestResource >> beAvailableFor: aTestSuite [ + self beAvailable +] + +{ #category : #accessing } +TestResource >> description [ + description isNil ifTrue: [^'']. + ^description +] + +{ #category : #accessing } +TestResource >> description: aString [ + description := aStrin +] + +{ #category : #initialization } +TestResource >> initialize [ + self setUp +] + +{ #category : #testing } +TestResource >> isAvailable [ + ^true +] + +{ #category : #testing } +TestResource >> isUnavailable [ + ^self isAvailable not +] + +{ #category : #accessing } +TestResource >> name [ + name isNil ifTrue: [^self printString]. + ^name +] + +{ #category : #accessing } +TestResource >> name: aString [ + name := aString +] + +{ #category : #printing } +TestResource >> printOn: aStream [ + aStream nextPutAll: self class printString +] + +{ #category : #accessing } +TestResource >> resources [ + ^self class resources +] + +{ #category : #'set up' } +TestResource >> setUp [ +] + +{ #category : #exceptions } +TestResource >> signalInitializationError [ + ^self class signalInitializationError +] + +{ #category : #finalization } +TestResource >> tearDown [ +] + diff --git a/modules/SUnit/TestResult.st b/modules/SUnit/TestResult.st new file mode 100644 index 0000000..4cb3942 --- /dev/null +++ b/modules/SUnit/TestResult.st @@ -0,0 +1,375 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestResult, + #superclass : #Object, + #instVars : [ + 'failures', + 'errors', + 'passed', + 'skipped' + ], + #category : #SUnit +} + +{ #category : #exceptions } +TestResult class >> error [ + ^self exError +] + +{ #category : #exceptions } +TestResult class >> exError [ + ^SUnitNameResolver errorObject +] + +{ #category : #exceptions } +TestResult class >> failure [ + ^TestFailure +] + +{ #category : #services } +TestResult class >> signalErrorWith: aString [ + self error sunitSignalWith: aString +] + +{ #category : #services } +TestResult class >> signalFailureWith: aString [ + self failure sunitSignalWith: aString +] + +{ #category : #exceptions } +TestResult class >> skipped [ + ^TestSkipped +] + +{ #category : #adding } +TestResult >> addAll: aTestResult [ + self failures addAll: aTestResult failures. + self errors addAll: aTestResult errors. + self passed addAll: aTestResult passed. + self skipped addAll: aTestResult skipped +] + +{ #category : #accessing } +TestResult >> caseCount [ + ^self runCount + self skippedCount +] + +{ #category : #accessing } +TestResult >> defects [ + ^OrderedCollection new + addAll: (self errors asArray sortBy: #printString); + addAll: (self failures asArray sortBy: #printString); + addAll: (self skipped asArray sortBy: #printString); + yourself +] + +{ #category : #accessing } +TestResult >> errorCount [ + ^self errors size +] + +{ #category : #accessing } +TestResult >> errors [ + errors isNil ifTrue: [errors := OrderedCollection new]. + ^errors +] + +{ #category : #accessing } +TestResult >> errors: aCollection [ + errors := aCollection +] + +{ #category : #adding } +TestResult >> export [ + ^Dictionary + withAll: {#failures -> (self failures collect: #export). + #errors -> (self errors collect: #export). + #passed -> (self passed collect: #export). + #skipped -> (self skipped collect: #export)} +] + +{ #category : #accessing } +TestResult >> failureCount [ + ^self failures size +] + +{ #category : #accessing } +TestResult >> failures [ + failures isNil ifTrue: [failures := OrderedCollection new]. + ^failures +] + +{ #category : #testing } +TestResult >> hasDefects [ + ^self hasErrors or: [failures anySatisfy: [:test | test isKnownIssue not]] +] + +{ #category : #testing } +TestResult >> hasErrors [ + ^self errors size > 0 +] + +{ #category : #testing } +TestResult >> hasFailures [ + ^self failures size > 0 +] + +{ #category : #testing } +TestResult >> hasPassed [ + ^self hasErrors not and: [self hasFailures not] +] + +{ #category : #accessing } +TestResult >> ignoreErrors: aBlock [ + errors notNil ifTrue: [errors removeAllSuchThat: aBlock] +] + +{ #category : #accessing } +TestResult >> ignoreFailures: aBlock [ + failures notNil ifTrue: [failures removeAllSuchThat: aBlock] +] + +{ #category : #adding } +TestResult >> importAll: exported using: aTestSuite [ + | all | + all := aTestSuite allCases. + exported keysAndValuesDo: [:name :contents | | imported collection | + imported := contents collect: [:data | | classname selector found | + classname := data at: 1. + selector := data at: 2. + found := all + detect: [:case | case selector = selector + and: [case class name = classname]]. + found importFrom: data]. + collection := self perform: name. + collection addAll: imported] +] + +{ #category : #initialization } +TestResult >> initialize [ +] + +{ #category : #testing } +TestResult >> isError: aTestCase [ + ^self errors includes: aTestCase +] + +{ #category : #testing } +TestResult >> isFailure: aTestCase [ + ^self failures includes: aTestCase +] + +{ #category : #testing } +TestResult >> isPassed: aTestCase [ + ^self passed includes: aTestCase +] + +{ #category : #testing } +TestResult >> isSkipped: aTestCase [ + ^self skipped includes: aTestCase +] + +{ #category : #accessing } +TestResult >> knownErrors [ + ^self errors select: [:f | f isKnownIssue] +] + +{ #category : #accessing } +TestResult >> knownFailures [ + ^self failures select: [:f | f isKnownIssue] +] + +{ #category : #accessing } +TestResult >> knownIssues [ + ^self knownFailures , self knownErrors +] + +{ #category : #accessing } +TestResult >> passed [ + passed isNil ifTrue: [passed := OrderedCollection new]. + ^passed +] + +{ #category : #accessing } +TestResult >> passedCount [ + ^self passed size +] + +{ #category : #printing } +TestResult >> printOn: aStream [ + self printStatisticsOn: aStream +] + +{ #category : #printing } +TestResult >> printStatisticsOn: aStream [ + | kf ke k f e | + kf := self knownFailures size. + ke := self knownErrors size. + k := kf + ke. + f := self failureCount - kf. + e := self errorCount - ke. + aStream + nextPutAll: self runCount printString; + nextPutAll: ' run, '; + nextPutAll: self passedCount printString; + nextPutAll: ' passed, '; + nextPutAll: f printString; + nextPutAll: ' failed, '; + nextPutAll: self skippedCount printString; + nextPutAll: ' skipped, '. + k > 0 ifTrue: [aStream print: k; nextPutAll: ' known issues, ']. + aStream print: e; nextPutAll: ' error'. + e != 1 ifTrue: [aStream nextPut: $s]. + e + f > 0 ifTrue: [aStream cr]. + f > 0 ifTrue: [ + aStream nextPutAll: 'Failures:'; cr. + self unknownFailures do: [:failure | aStream print: failure; cr]]. + e > 0 ifTrue: [ + aStream nextPutAll: 'Errors:'; cr. + self unknownErrors do: [:error | aStream print: error; cr]]. +] + +{ #category : #running } +TestResult >> runCase: aTestCase [ + | success t | + success := [ + t := Kernel host currentMilliseconds. + aTestCase runCase; time: Kernel host currentMilliseconds - t. + true] + sunitOn: self class failure + do: [:signal | + aTestCase time: Kernel host currentMilliseconds - t. + self failures add: aTestCase. + signal sunitExitWith: false] + on: self class skipped + do: [:signal | + aTestCase time: Kernel host currentMilliseconds - t. + self skipped add: aTestCase. + signal sunitExitWith: false] + on: self class error + do: [:signal | + aTestCase time: Kernel host currentMilliseconds - t. + self errors add: aTestCase. + signal sunitExitWith: false]. + success ifTrue: [self passed add: aTestCase] +] + +{ #category : #running } +TestResult >> runCaseAsError: aTestCase [ + | new | + self errors add: aTestCase. + new := aTestCase debugAsFailure. + self errors remove: aTestCase. + self passed add: new +] + +{ #category : #running } +TestResult >> runCaseAsFailure: aTestCase [ + | new | + self failures add: aTestCase. + new := aTestCase debugAsFailure. + self failures remove: aTestCase. + self passed add: new +] + +{ #category : #running } +TestResult >> runCaseRefresh: aTestCase [ + | failure error | + failure := self isFailure: aTestCase. + error := self isError: aTestCase. + self passed remove: aTestCase ifAbsent: nil. + self failures remove: aTestCase ifAbsent: nil. + self errors remove: aTestCase ifAbsent: nil. + failure ifTrue: [self runCaseAsFailure: aTestCase] ifFalse: [ + error + ifTrue: [self runCaseAsError: aTestCase] + ifFalse: [self runCase: aTestCase]] +] + +{ #category : #accessing } +TestResult >> runCount [ + ^self passedCount + self failureCount + self errorCount +] + +{ #category : #accessing } +TestResult >> skipAll: cases [ + | s e | + s := self skipped. + cases do: [:case | s addIfAbsent: case] +] + +{ #category : #accessing } +TestResult >> skipped [ + skipped isNil ifTrue: [skipped := OrderedCollection new]. + ^skipped +] + +{ #category : #accessing } +TestResult >> skippedCount [ + ^self skipped size +] + +{ #category : #services } +TestResult >> stateFor: aTestCase [ + | answer | + (self isPassed: aTestCase) ifTrue: [answer := 'Pass']. + (self isFailure: aTestCase) ifTrue: [answer := 'Failure']. + (self isError: aTestCase) ifTrue: [answer := 'Error']. + (self isSkipped: aTestCase) ifTrue: [answer := 'Skipped']. + aTestCase isKnownIssue ifTrue: [answer := answer , ' (known)']. + ^answer +] + +{ #category : #adding } +TestResult >> takeOut: aTestResult [ + self failures removeAll: aTestResult failures ifAbsent: nil. + self errors removeAll: aTestResult errors ifAbsent: nil. + self passed removeAll: aTestResult passed +] + +{ #category : #accessing } +TestResult >> tests [ + ^(OrderedCollection new: self runCount) + addAll: self passed; + addAll: self errors; + addAll: self failures; + addAll: self skipped; + yourself +] + +{ #category : #accessing } +TestResult >> totalCases [ + ^self passedCount + self failureCount + self errorCount +] + +{ #category : #accessing } +TestResult >> totalChecks [ + ^self tests sum: [:test | test totalChecks] ifNone: 0 +] + +{ #category : #accessing } +TestResult >> totalTime [ + ^(self passed sum: [:testCase | testCase time] ifNone: [0]) + + (self failures sum: [:testCase | testCase time] ifNone: [0]) + + (self errors sum: [:testCase | testCase time] ifNone: [0]) +] + +{ #category : #accessing } +TestResult >> unknownErrors [ + ^self errors reject: [:f | f isKnownIssue] +] + +{ #category : #accessing } +TestResult >> unknownFailures [ + ^self failures reject: [:f | f isKnownIssue] +] + +{ #category : #adding } +TestResult >> withAll: aTestResult [ + self addAll: aTestResult +] + diff --git a/modules/SUnit/TestSkipped.st b/modules/SUnit/TestSkipped.st new file mode 100644 index 0000000..e6b3bdb --- /dev/null +++ b/modules/SUnit/TestSkipped.st @@ -0,0 +1,16 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestSkipped, + #superclass : #Notification, + #category : #SUnit +} + +{ #category : #testing } +TestSkipped >> isResumable [ + ^false +] + diff --git a/modules/SUnit/TestSuite.st b/modules/SUnit/TestSuite.st new file mode 100644 index 0000000..cd1c692 --- /dev/null +++ b/modules/SUnit/TestSuite.st @@ -0,0 +1,285 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #TestSuite, + #superclass : #Object, + #instVars : [ + 'tests', + 'resources', + 'name', + 'view', + 'current', + 'stop' + ], + #category : #SUnit +} + +{ #category : #events } +TestSuite class >> availableEvents [ + ^super availableEvents add: #resultChanged:; yourself +] + +{ #category : #'instance creation' } +TestSuite class >> fromString: aString [ + | suite cm | + suite := self named: 'From strings'. + aString lines do: [:line | + cm := CompiledMethod fromSignature: line withoutSeparators. + suite addTest: (cm classBinding selector: cm selector)]. + ^suite +] + +{ #category : #'instance creation' } +TestSuite class >> named: aString [ + ^self new name: aString; yourself +] + +{ #category : #'instance creation' } +TestSuite class >> named: aString with: objects [ + | tests | + tests := objects collect: [:o | + o isClass ifTrue: [o buildSuiteFromSelectors] ifFalse: [ + self ASSERT: o isAssociation. + o key buildSuiteFromMethods: {o value}]]. + ^self named: aString withTests: tests +] + +{ #category : #'instance creation' } +TestSuite class >> named: aString withTests: aCollection [ + ^self new name: aString; addTests: aCollection +] + +{ #category : #accessing } +TestSuite >> addDependent: anObject [ + self when: #changed send: #update to: anObject +] + +{ #category : #accessing } +TestSuite >> addDependentToHierachy: anObject [ + self addDependent: anObject. + self tests do: [:each | each addDependentToHierachy: anObject] +] + +{ #category : #accessing } +TestSuite >> addDependentToHierarchy: anObject [ + self addDependent: anObject. + self tests do: [:each | each addDependentToHierarchy: anObject] +] + +{ #category : #accessing } +TestSuite >> addTest: test [ + test suite: self. + self tests add: test +] + +{ #category : #accessing } +TestSuite >> addTests: aCollection [ + aCollection do: [:test | self addTest: test] +] + +{ #category : #running } +TestSuite >> allCases [ + ^self tests gather: [:test | test allCases] +] + +{ #category : #accessing } +TestSuite >> anyTest [ + tests isNil ifTrue: [^nil]. + tests isEmpty ifTrue: [^nil]. + ^tests anyone anyTest +] + +{ #category : #running } +TestSuite >> basicRun: aTestResult [ + self tests do: [:test | + self run: test result: aTestResult] +] + +{ #category : #exceptions } +TestSuite >> caseCount [ + ^self tests sum: #caseCount +] + +{ #category : #accessing } +TestSuite >> currentTest [ + ^current notNil ifTrue: [current currentTest] +] + +{ #category : #private } +TestSuite >> defaultResources [ + | default | + default := Dictionary new. + self tests do: [:test | + test resources do: [:resource | | users | + users := default at: resource ifAbsentPut: [OrderedCollection new]. + users add: test]]. + ^default +] + +{ #category : #accessing } +TestSuite >> innerSuites [ + ^tests isNil + ifTrue: [#()] + ifFalse: [tests select: [:t | t isKindOf: TestSuite]] +] + +{ #category : #comparing } +TestSuite >> isLike: aTestSuite [ + aTestSuite class == self class ifFalse: [^false]. + ^aTestSuite name = name +] + +{ #category : #accessing } +TestSuite >> name [ + ^name +] + +{ #category : #accessing } +TestSuite >> name: aString [ + name := aString +] + +{ #category : #printing } +TestSuite >> printOn: aStream [ + name isNil ifTrue: [^super printOn: aStream]. + aStream + nextPutAll: self class name; + nextPutAll: ' for '; + nextPutAll: name +] + +{ #category : #accessing } +TestSuite >> removeAllSuchThat: aBlock [ + tests isNil ifTrue: [^self]. + tests removeAllSuchThat: aBlock. + tests do: [:test | test removeAllSuchThat: aBlock] +] + +{ #category : #accessing } +TestSuite >> removeDependentFromHierachy: anObject [ + self removeDependent: anObject. + self tests do: [:each | each removeDependentFromHierachy: anObject] +] + +{ #category : #accessing } +TestSuite >> removeDependentFromHierarchy: anObject [ + self removeDependent: anObject. + self tests do: [:each | each removeDependentFromHierarchy: anObject] +] + +{ #category : #accessing } +TestSuite >> removeTests: aCollection [ + self + removeAllSuchThat: [:t | aCollection anySatisfy: [:test | test isLike: t]] +] + +{ #category : #accessing } +TestSuite >> resources [ + resources isNil ifTrue: [resources := self defaultResources]. + ^resources keys +] + +{ #category : #private } +TestSuite >> resultChanged: aTestResult [ + "self triggerEvent: #resultChanged: with: aTestResult" +] + +{ #category : #running } +TestSuite >> run [ + | result | + result := TestResult new. + self run: result. + ^result +] + +{ #category : #running } +TestSuite >> run: aTestResult [ + | res | + res := self setUpResources: aTestResult. + [ + stop == true ifTrue: [^self]. + self basicRun: aTestResult] + sunitEnsure: [res do: [:resource | resource reset]] +] + +{ #category : #running } +TestSuite >> run: test result: aTestResult [ + current := test. +" self changed: self." + stop == true ifTrue: [^self]. + (test isKindOf: TestSuite) ifTrue: [ + "test + when: #changed: send: #changed: to: self; + when: #resultChanged: send: #resultChanged: to: self"]. + test basicRun: aTestResult. + self resultChanged: aTestResult +] + +{ #category : #running } +TestSuite >> setUpResources: aTestResult [ + | res | + res := [self resources] on: Error do: [ + aTestResult skipAll: self allCases. + {}]. + res do: [:resource | + [resource beAvailableFor: self] + on: Error + do: [self skipTestsUsing: resource in: aTestResult]]. + ^res +] + +{ #category : #accessing } +TestSuite >> size [ + ^tests isNil + ifTrue: [0] + ifFalse: [tests + sum: [:t | (t isKindOf: TestCase) ifTrue: [1] ifFalse: [t size]]] +] + +{ #category : #running } +TestSuite >> skipTestsUsing: aResource in: aTestResult [ + | users | + users := resources at: aResource. + users do: [:test | aTestResult skipAll: test allCases] +] + +{ #category : #running } +TestSuite >> stop [ + self stop: true +] + +{ #category : #running } +TestSuite >> stop: aBoolean [ + stop := aBoolean. + tests notNil ifTrue: [tests do: [:suite | suite stop: aBoolean]] +] + +{ #category : #accessing } +TestSuite >> suite [ + ^self +] + +{ #category : #accessing } +TestSuite >> suite: aTestSuite [ + " + Do nothing, compatibility with TestCase + " +] + +{ #category : #accessing } +TestSuite >> tests [ + tests isNil ifTrue: [tests := OrderedCollection new]. + ^tests + +] + +{ #category : #exceptions } +TestSuite >> uniqueCaseCount [ + | signatures | + signatures := self allCases collect: #signature. + ^signatures withoutDuplicates size +] + diff --git a/modules/SUnit/Tests/ExampleSetTest.st b/modules/SUnit/Tests/ExampleSetTest.st new file mode 100644 index 0000000..9aa9f2e --- /dev/null +++ b/modules/SUnit/Tests/ExampleSetTest.st @@ -0,0 +1,64 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #ExampleSetTest, + #superclass : #TestCase, + #instVars : [ + 'full', + 'empty' + ], + #category : #'SUnit.Tests' +} + +{ #category : #'set up' } +ExampleSetTest >> setUp [ + empty := Set new. + full := Set with: 5 with: #abc +] + +{ #category : #all } +ExampleSetTest >> testAdd [ + empty add: 5. + self assert: (empty includes: 5) +] + +{ #category : #all } +ExampleSetTest >> testGrow [ + empty addAll: (1 to: 100). + self assert: empty size = 100 +] + +{ #category : #all } +ExampleSetTest >> testIllegal [ + self + should: [empty at: 5] + raise: TestResult error. + self + should: [empty at: 5 put: #abc] + raise: TestResult error +] + +{ #category : #all } +ExampleSetTest >> testIncludes [ + self assert: (full includes: 5). + self assert: (full includes: #abc) +] + +{ #category : #all } +ExampleSetTest >> testOccurrences [ + self assert: (empty occurrencesOf: 0) = 0. + self assert: (full occurrencesOf: 5) = 1. + full add: 5. + self assert: (full occurrencesOf: 5) = 1 +] + +{ #category : #all } +ExampleSetTest >> testRemove [ + full remove: 5. + self assert: (full includes: #abc). + self deny: (full includes: 5) +] + diff --git a/modules/SUnit/Tests/ResumableTestFailureTestCase.st b/modules/SUnit/Tests/ResumableTestFailureTestCase.st new file mode 100644 index 0000000..86dc92c --- /dev/null +++ b/modules/SUnit/Tests/ResumableTestFailureTestCase.st @@ -0,0 +1,67 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #ResumableTestFailureTestCase, + #superclass : #TestCase, + #category : #'SUnit.Tests' +} + +{ #category : #unclassified } +ResumableTestFailureTestCase >> errorTest [ + 1 zork +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> failureLog [ + ^SUnitNameResolver defaultLogDevice +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> failureTest [ + self + assert: false description: 'You should see me' resumable: true; + assert: false description: 'You should see me too' resumable: true; + assert: false description: 'You should see me last' resumable: false; + assert: false description: 'You should not see me' resumable: true +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> isLogging [ + ^false +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> okTest [ + self assert: true +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> regularTestFailureTest [ + self assert: false description: 'You should see me' +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> resumableTestFailureTest [ + self + assert: false description: 'You should see me' resumable: true; + assert: false description: 'You should see me too' resumable: true; + assert: false description: 'You should see me last' resumable: false; + assert: false description: 'You should not see me' resumable: true +] + +{ #category : #unclassified } +ResumableTestFailureTestCase >> testResumable [ + | result suite | + suite := TestSuite new. + suite addTest: (self class selector: #errorTest). + suite addTest: (self class selector: #regularTestFailureTest). + suite addTest: (self class selector: #resumableTestFailureTest). + suite addTest: (self class selector: #okTest). + result := suite run. + self assert: result failures size = 2; + assert: result errors size = 1 +] + diff --git a/modules/SUnit/Tests/SUnitTest.st b/modules/SUnit/Tests/SUnitTest.st new file mode 100644 index 0000000..be69d11 --- /dev/null +++ b/modules/SUnit/Tests/SUnitTest.st @@ -0,0 +1,301 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #SUnitTest, + #superclass : #TestCase, + #instVars : [ + 'hasRun', + 'hasSetup', + 'hasRanOnce' + ], + #category : #'SUnit.Tests' +} + +{ #category : #testing } +SUnitTest class >> shouldInheritSelectors [ + ^false +] + +{ #category : #private } +SUnitTest >> error [ + 3 zork +] + +{ #category : #private } +SUnitTest >> errorShouldntRaise [ + self + shouldnt: [self someMessageThatIsntUnderstood] + raise: SUnitNameResolver notificationObject +] + +{ #category : #private } +SUnitTest >> fail [ + self assert: false +] + +{ #category : #testing } +SUnitTest >> hasRun [ + ^hasRun +] + +{ #category : #testing } +SUnitTest >> hasSetup [ + ^hasSetup +] + +{ #category : #private } +SUnitTest >> noop [ +] + +{ #category : #accessing } +SUnitTest >> setRun [ + hasRun := true +] + +{ #category : #'set up' } +SUnitTest >> setUp [ + super setUp. + hasSetup := true +] + +{ #category : #private } +SUnitTest >> skip [ + self skipIf: true description: 'this test is skipped' +] + +{ #category : #all } +SUnitTest >> testAssert [ + self assert: true; deny: false +] + +{ #category : #all } +SUnitTest >> log: message [ + Kernel log: message, String cr +] + +{ #category : #all } +SUnitTest >> testCounter [ + | assert deny shouldnt description | + assert := counter occurrencesOf: #assert:. + deny := counter occurrencesOf: #deny:. + shouldnt := counter occurrencesOf: #shouldnt:raise:. + description := counter occurrencesOf: #assert:description:. + self + assert: true; + assert: assert + 1 = (counter occurrencesOf: #assert:) + description: 'Failure counting asserts'; + deny: false; + assert: deny + 1 = (counter occurrencesOf: #deny:) + description: 'Failure counting denys'; + shouldnt: [] raise: Error; + assert: shouldnt + 1 = (counter occurrencesOf: #shouldnt:raise:) + description: 'Failure counting #shouldnt:raise:'; + assert: description + 3 = (counter occurrencesOf: #assert:description:) +] + +{ #category : #all } +SUnitTest >> testDefects [ + | error failure suite result | + error := self class selector: #error. + failure := self class selector: #fail. + suite := TestSuite new. + suite addTest: error; addTest: failure. + result := suite run. + self + assert: result defects asArray = (Array with: error with: failure); + assert: result runCount = 2; + assert: result passedCount = 0; + assert: result failureCount = 1; + assert: result errorCount = 1 +] + +{ #category : #all } +SUnitTest >> testDialectLocalizedException [ + self + should: [TestResult signalFailureWith: 'Foo'] + raise: TestResult failure. + self should: [TestResult signalErrorWith: 'Foo'] raise: TestResult error +] + +{ #category : #all } +SUnitTest >> testError [ + | case result | + case := self class selector: #error. + result := case run. + self + assert: result runCount = 1; + assert: result passedCount = 0; + assert: result failureCount = 0; + assert: result errorCount = 1. + case := self class selector: #errorShouldntRaise. + result := case run. + self + assert: result runCount = 1; + assert: result passedCount = 0; + assert: result failureCount = 0; + assert: result errorCount = 1 +] + +{ #category : #all } +SUnitTest >> testException [ + self should: [self error: 'foo'] raise: TestResult error +] + +{ #category : #all } +SUnitTest >> testFail [ + | case result | + case := self class selector: #fail. + result := case run. + self + assert: result runCount = 1; + assert: result passedCount = 0; + assert: result failureCount = 1; + assert: result errorCount = 0 +] + +{ #category : #all } +SUnitTest >> testIsNotRerunOnDebug [ + | case | + case := self class selector: #testRanOnlyOnce. + case run. + case debug +] + +{ #category : #all } +SUnitTest >> testRan [ + | case | + case := self class selector: #setRun. + case run. + self assert: case hasSetup. + self assert: case hasRun +] + +{ #category : #all } +SUnitTest >> testRandomGenerator [ + | seed | + seed := self random seed. + self random next. + self deny: self random seed = seed +] + +{ #category : #all } +SUnitTest >> testRanOnlyOnce [ + self assert: hasRanOnce ~= true. + hasRanOnce := true +] + +{ #category : #all } +SUnitTest >> testRemoveTests [ + | suite inner | + suite := TestSuite new. + inner := TestSuite named: 'inner'. + inner + addTest: (TestCase selector: #a); + addTest: (TestCase selector: #b). + suite + addTest: inner; + addTest: (TestCase selector: #c). + suite removeTests: {TestCase selector: #a}. + self + deny: (suite tests + anySatisfy: [:test | test tests anySatisfy: [:t | t selector == #a]]); + assert: (suite tests + anySatisfy: [:test | test tests anySatisfy: [:t | t selector == #b]]); + assert: (suite tests + anySatisfy: [:test | test tests anySatisfy: [:t | t selector == #c]]). + suite removeTests: {TestSuite named: 'inner'. TestCase selector: #c}. + self assert: suite tests isEmpty +] + +{ #category : #all } +SUnitTest >> testResult [ + | case result | + case := self class selector: #noop. + result := case run. + self + assert: result runCount = 1; + assert: result passedCount = 1; + assert: result failureCount = 0; + assert: result errorCount = 0 +] + +{ #category : #accessing } +SUnitTest >> testSelectors [ + TestCase allSubclasses + do: [:class | self deny: (class allTestSelectors includes: #tests)] +] + +{ #category : #all } +SUnitTest >> testShould [ + self should: [true]; shouldnt: [false] +] + +{ #category : #all } +SUnitTest >> testSkip [ + | case result | + case := self class selector: #skip. + result := case run. + self + assert: result runCount = 0; + assert: result passedCount = 0; + assert: result failureCount = 0; + assert: result errorCount = 0; + assert: result skippedCount = 1 +] + +{ #category : #all } +SUnitTest >> testSuite [ + | noop fail error suite result | + noop := self class selector: #noop. + fail := self class selector: #fail. + error := self class selector: #error. + suite := TestSuite new. + suite + addTest: noop; + addTest: fail; + addTest: error. + result := suite run. + self + assert: result runCount = 3; + assert: result passedCount = 1; + assert: result failureCount = 1; + assert: result errorCount = 1; + assert: noop time >= 0; + assert: error time >= 0; + assert: fail time >= 0 +] + +{ #category : #all } +SUnitTest >> testTestRandomGenerator [ + | seed case | + case := self class selector: #testRandomGenerator. + seed := case random seed. + case run. + case setUp. + self + assert: case random seed == seed + description: 'Initial seed not restored in RandomGenerator' +] + +{ #category : #all } +SUnitTest >> testTime [ + "(Delay forSeconds: 1) wait. + self assert: self time >= 1000" +] + +{ #category : #all } +SUnitTest >> testTotalChecks [ + | suite result test total | + suite := TestSuite new. + suite addTest: (self class selector: #testCounter). + result := suite run. + test := result passed anyone. + total := test totalChecks. + result := suite run. + test := result passed anyone. + self assert: total = test totalChecks +] + diff --git a/modules/SUnit/Tests/SimpleTestResource.st b/modules/SUnit/Tests/SimpleTestResource.st new file mode 100644 index 0000000..a110dd3 --- /dev/null +++ b/modules/SUnit/Tests/SimpleTestResource.st @@ -0,0 +1,67 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #SimpleTestResource, + #superclass : #TestResource, + #instVars : [ + 'runningState', + 'hasRun', + 'hasSetup', + 'hasRanOnce' + ], + #category : #'SUnit.Tests' +} + +{ #category : #unclassified } +SimpleTestResource >> hasRun [ + ^hasRun +] + +{ #category : #unclassified } +SimpleTestResource >> hasSetup [ + ^hasSetup +] + +{ #category : #unclassified } +SimpleTestResource >> isAvailable [ + ^self runningState == self startedStateSymbol] + +{ #category : #unclassified } +SimpleTestResource >> runningState [ + ^runningState +] + +{ #category : #unclassified } +SimpleTestResource >> runningState: aSymbol [ + runningState := aSymbol +] + +{ #category : #unclassified } +SimpleTestResource >> setRun [ + hasRun := true +] + +{ #category : #'set up' } +SimpleTestResource >> setUp [ + self runningState: self startedStateSymbol. + hasSetup := true +] + +{ #category : #unclassified } +SimpleTestResource >> startedStateSymbol [ + ^#started +] + +{ #category : #unclassified } +SimpleTestResource >> stoppedStateSymbol [ + ^#stopped +] + +{ #category : #finalization } +SimpleTestResource >> tearDown [ + self runningState: self stoppedStateSymbol +] + diff --git a/modules/SUnit/Tests/SimpleTestResourceTestCase.st b/modules/SUnit/Tests/SimpleTestResourceTestCase.st new file mode 100644 index 0000000..7c18dc5 --- /dev/null +++ b/modules/SUnit/Tests/SimpleTestResourceTestCase.st @@ -0,0 +1,72 @@ +" + Copyright (c) 2021 Aucerna. + See (MIT) license in root directory. +" + +Class { + #name : #SimpleTestResourceTestCase, + #superclass : #TestCase, + #instVars : [ + 'resource' + ], + #category : #'SUnit.Tests' +} + +{ #category : #unclassified } +SimpleTestResourceTestCase class >> resources [ + ^Set new add: SimpleTestResource; yourself +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> dummy [ + self assert: true +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> error [ + 'foo' odd +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> fail [ + self assert: false +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> setRun [ + resource setRun +] + +{ #category : #'set up' } +SimpleTestResourceTestCase >> setUp [ + resource := SimpleTestResource current +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> testRan [ + | case | + + case := self class selector: #setRun. + case run. + self assert: resource hasSetup. + self assert: resource hasRun +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> testResourceInitRelease [ + | result suite error failure | + suite := TestSuite new. + suite addTest: (error := self class selector: #error). + suite addTest: (failure := self class selector: #fail). + suite addTest: (self class selector: #dummy). + result := suite run. + self assert: resource hasSetup +] + +{ #category : #unclassified } +SimpleTestResourceTestCase >> testResourcesCollection [ + | collection | + collection := self resources. + self assert: collection size = 1 +] + diff --git a/modules/SUnit/Tests/TestsModule.st b/modules/SUnit/Tests/TestsModule.st new file mode 100644 index 0000000..06f7a1b --- /dev/null +++ b/modules/SUnit/Tests/TestsModule.st @@ -0,0 +1,29 @@ +Class { + #name : #TestsModule, + #superclass : #Module, + #category : #Test +} + +{ #category : #spec } +TestsModule >> imports [ + ^{ + #Kernel -> #(Error). + #SUnit -> #(SUnitNameResolver TestCase TestResource TestResult TestSuite) + } +] + +{ #category : #spec } +TestsModule >> initialize [ + super initialize +] + +{ #category : #spec } +TestsModule >> main: args [ + | result | + Kernel log: 'running tests...', String cr. + + result := SUnitTest buildTestSuite run. + Kernel log: 'done', String cr. + Kernel log: 'Results: ', String cr. + Kernel log: result printString, String cr, String cr. +] \ No newline at end of file From 772bdd02f96632d3a833c0047a29de02f6024497 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:06:56 -0300 Subject: [PATCH 02/11] [kernel] float>>#= failure asks fpu status only when arg was also float --- modules/Kernel/VM/Float.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/Kernel/VM/Float.st b/modules/Kernel/VM/Float.st index 1fb115b..b84dd75 100644 --- a/modules/Kernel/VM/Float.st +++ b/modules/Kernel/VM/Float.st @@ -66,9 +66,9 @@ Float >> < aNumber [ Float >> = aNumber [ | nan status | - status := Float status. ^aNumber isFloat ifTrue: [ + status := Float status. nan := self isNaN. (nan and: [aNumber isNaN]) ifTrue: [^true]. (nan or: [aNumber isNaN]) ifTrue: [^false]. From dd2d561c02deef060da859f9ca70761799227735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:10:09 -0300 Subject: [PATCH 03/11] [kernel] fix ensure support --- modules/Kernel/ActiveProcess.st | 55 ++++++++++++++++++++++++++++-- modules/Kernel/Closure.st | 27 +++------------ modules/Kernel/ExceptionHandler.st | 16 +++++++++ modules/Kernel/Process.st | 1 + modules/Kernel/ProcessStack.st | 9 ++++- 5 files changed, 83 insertions(+), 25 deletions(-) diff --git a/modules/Kernel/ActiveProcess.st b/modules/Kernel/ActiveProcess.st index a37efbe..8373bf6 100644 --- a/modules/Kernel/ActiveProcess.st +++ b/modules/Kernel/ActiveProcess.st @@ -19,6 +19,20 @@ ActiveProcess >> beInactive [ self changeClassTo: SuspendedProcess ] +{ #category : #converting } +ActiveProcess >> canReturnTo: homeFrame [ + + | method env | + homeFrame == nil ifTrue: [^false]. + homeFrame < self nativeStack bp ifTrue: [^false]. + ^true + "method := self codeAt: homeFrame. + homeFrame hasBlocks ifFalse: [^false]. + env := self methodEnvironment. + homeFrame environment == env ifTrue: [^true]. + ^homeFrame methodEnvironment == env" +] + { #category : #private } ActiveProcess >> drop [ " @@ -40,7 +54,7 @@ ActiveProcess >> evaluate: aClosure ensuring: ensuredClosure [ have to update the frame indices if the stack frames are changed. " | cursor result prev | - cursor := nativeStack bp. + cursor := self nativeStack bp. protectedFrames push: cursor. result := aClosure value. prev := protectedFrames pop. @@ -51,6 +65,24 @@ ActiveProcess >> evaluate: aClosure ensuring: ensuredClosure [ ^result ] +{ #category : #private } +ActiveProcess >> evaluateEnsuredUpTo: framePointer [ + " + Marked as atomic because the protected frames are removed on + denativization and recreated on nativization, so stepping through the + loop in this method could have undesired consequences. + Ensured closure is the argument to the evaluate:ensuring: method, which protectedFrames + point to. + " + | ensured | + #atomic. + [ + protectedFrames notEmpty and: [protectedFrames last <= framePointer]] + whileTrue: [ + ensured := self nativeStack lastArgumentOf: protectedFrames pop. + ensured value]. +] + { #category : #private } ActiveProcess >> launch: aMessage [ exceptionHandler := nil. @@ -58,12 +90,31 @@ ActiveProcess >> launch: aMessage [ self drop; ASSERT: false ] +{ #category : #private } +ActiveProcess >> nonLocalReturn: anObject home: framePointer [ + " + The home frame of closure is the start of the chain (might be another + cloure). We look for the method frame, evaluate any protected blocks + in the way and return. + + We assume homeFrame is a valid index, which is guaranteed because: + - it is captured in the active process + - it is niled out when putting the process to sleep + - it is refreshed when process is reactivated + " + (self canReturnTo: framePointer) + ifFalse: [self error: 'cannot return to a frame outside current stack chunk']. + + self evaluateEnsuredUpTo: framePointer. + ^anObject _returnTo: framePointer +] + { #category : #private } ActiveProcess >> snapshot [ " Saves current state to allow resuming later " - ^nativeStack snapshot + ^self nativeStack snapshot ] ActiveProcess >> useExceptionHandler: anExceptionHandler while: aBlock [ diff --git a/modules/Kernel/Closure.st b/modules/Kernel/Closure.st index 9c202a1..982e1d8 100644 --- a/modules/Kernel/Closure.st +++ b/modules/Kernel/Closure.st @@ -41,12 +41,6 @@ Closure class >> receiverIndex [ ^ReceiverIndex ] -{ #category : #handling } -Closure >> _return: result [ - self canReturn ifFalse: [^self cannotReturn]. - ^Processor activeProcess returnTo: homeFrame methodFrame with: result -] - { #category : #accessing } Closure >> argumentCount [ ^block argumentCount @@ -93,17 +87,6 @@ Closure >> blockNumber [ ^block blockNumber ] -{ #category : #converting } -Closure >> canReturn [ - | env | - homeFrame == nil ifTrue: [^false]. - homeFrame stackPointer < self _thisContext ifTrue: [^false]. - homeFrame hasBlocks ifFalse: [^false]. - env := self methodEnvironment. - homeFrame environment == env ifTrue: [^true]. - ^homeFrame methodEnvironment == env -] - { #category : #evaluating } Closure >> cull: a [ ^self argumentCount < 1 @@ -239,11 +222,6 @@ Closure >> methodEnvironment: environment [ self at: ParentEnvironmentIndex put: environment ] -{ #category : #accessing } -Closure >> methodFrame [ - ^homeFrame methodFrame -] - { #category : #handling } Closure >> needsArgument [ ^self argumentCount > 0 @@ -321,6 +299,11 @@ Closure >> repeatUntil: aBlock [ aBlock value] whileFalse ] +{ #category : #private } +Closure >> return: result [ + ^Processor activeProcess nonLocalReturn: result home: homeFrame +] + { #category : #handling } Closure >> spawnAndWait [ | s result | diff --git a/modules/Kernel/ExceptionHandler.st b/modules/Kernel/ExceptionHandler.st index 2f18bd4..013a7f3 100644 --- a/modules/Kernel/ExceptionHandler.st +++ b/modules/Kernel/ExceptionHandler.st @@ -90,6 +90,22 @@ ExceptionHandler >> nextHandlerFor: anException [ ^previous notNil ifTrue: [previous findHandlerFor: anException] ] +{ #category : #handling } +ExceptionHandler >> printOn: aStream [ + aStream + nextPutAll: self class name withArticle; cr; + nextPutAll: ' for '; + nextPutAll: filter printString; cr; + nextPutAll: ' with handler '; cr; + nextPutAll: handlerBlock printString; cr; + nextPutAll: ' and protected block '; cr; + nextPutAll: protectedBlock printString; cr; + nextPutAll: ' returning '; + nextPutAll: return printString; cr; + nextPutAll: ' previous handler '; + nextPutAll: previous printString; cr +] + { #category : #handling } ExceptionHandler >> retry [ self return: self retryToken diff --git a/modules/Kernel/Process.st b/modules/Kernel/Process.st index 142fc70..b074ae9 100644 --- a/modules/Kernel/Process.st +++ b/modules/Kernel/Process.st @@ -109,6 +109,7 @@ Process >> name: aString [ { #category : #accessing } Process >> nativeStack [ + nativeStack ifNil: [self initializeStack]. ^nativeStack ] diff --git a/modules/Kernel/ProcessStack.st b/modules/Kernel/ProcessStack.st index 9f64dca..76ed70c 100644 --- a/modules/Kernel/ProcessStack.st +++ b/modules/Kernel/ProcessStack.st @@ -19,12 +19,19 @@ ProcessStack class >> on: aProcess [ ^self errorVMSpecific ] +{ #category : #services } +ProcessStack >> lastArgumentOf: frame [ + " + Given the base index of a frame, then comes retaddr, then last argument passed in the invokation + " + ^self at: frame + 2 +] + { #category : #services } ProcessStack >> contextSwitchTo: next [ self subclassResponsibility ] - { #category : #services } ProcessStack >> fillFrom: aContext [ #CRITICAL. From adfea5daa1b5d1e114401821b7b6840ca6b79852 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:11:52 -0300 Subject: [PATCH 04/11] [vm-cpp] add debugging method to print heap object slots --- runtime/cpp/HeapObject.cpp | 16 ++++++++++++++++ runtime/cpp/HeapObject.h | 1 + runtime/cpp/Object.cpp | 7 +++++++ runtime/cpp/Object.h | 1 + 4 files changed, 25 insertions(+) diff --git a/runtime/cpp/HeapObject.cpp b/runtime/cpp/HeapObject.cpp index 1ae9e78..cf12689 100644 --- a/runtime/cpp/HeapObject.cpp +++ b/runtime/cpp/HeapObject.cpp @@ -3,6 +3,8 @@ See (MIT) license in root directory. */ +#include + #include "HeapObject.h" #include "KnownObjects.h" #include "Evaluator/Runtime.h" @@ -363,6 +365,20 @@ std::string Egg::HeapObject::printString() return debugRuntime->print_(this); } +std::string Egg::HeapObject::printContents() +{ + auto size = this->size(); + std::ostringstream result; + result << "object class: " << debugRuntime->speciesOf_((Object*)this)->printString() << std::endl; + result << "slots:" << std::endl; + for (size_t i = 1; i <= size; i++) + { + result << "slot " << i << ":\t" << this->slotAt_(i)->printString() << std::endl; + } + + return result.str(); +} + void HeapObject::copyFrom_headerSize_bodySize_(HeapObject *object, uintptr_t headerSize, uintptr_t bodySize) { auto srcbase = ((uintptr_t)object) - headerSize; diff --git a/runtime/cpp/HeapObject.h b/runtime/cpp/HeapObject.h index 0620c12..304a243 100644 --- a/runtime/cpp/HeapObject.h +++ b/runtime/cpp/HeapObject.h @@ -263,6 +263,7 @@ struct HeapObject HeapObject* klass(); std::string printString(); + std::string printContents(); std::string stringVal(); std::string asLocalString(); diff --git a/runtime/cpp/Object.cpp b/runtime/cpp/Object.cpp index 231a792..6b1f388 100644 --- a/runtime/cpp/Object.cpp +++ b/runtime/cpp/Object.cpp @@ -9,4 +9,11 @@ std::string Object::printString() return this->isSmallInteger() ? this->asSmallInteger()->printString() : this->asHeapObject()->printString(); +} + +std::string Object::printContents() +{ + return this->isSmallInteger() ? + this->printString() : + this->asHeapObject()->printContents(); } \ No newline at end of file diff --git a/runtime/cpp/Object.h b/runtime/cpp/Object.h index 0e69c72..3908e3c 100644 --- a/runtime/cpp/Object.h +++ b/runtime/cpp/Object.h @@ -63,6 +63,7 @@ struct Object // debugging std::string printString(); + std::string printContents(); }; } // namespace Egg From 81a1159bbc31ceaf2e36b629aa76667ba2255f71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:18:51 -0300 Subject: [PATCH 05/11] [vm-cpp] add vm ensure support, including better unwinding with returnTo underprim and process primitives --- runtime/cpp/Evaluator/EvaluationContext.cpp | 26 ++--------- runtime/cpp/Evaluator/EvaluationContext.h | 5 ++- runtime/cpp/Evaluator/Evaluator.cpp | 48 +++++++++++++-------- runtime/cpp/Evaluator/Evaluator.h | 2 + runtime/cpp/Evaluator/Runtime.cpp | 2 + runtime/cpp/Evaluator/Runtime.h | 16 +++++++ runtime/cpp/KnownConstants.h | 1 + 7 files changed, 59 insertions(+), 41 deletions(-) diff --git a/runtime/cpp/Evaluator/EvaluationContext.cpp b/runtime/cpp/Evaluator/EvaluationContext.cpp index bfbb33e..9cf6102 100644 --- a/runtime/cpp/Evaluator/EvaluationContext.cpp +++ b/runtime/cpp/Evaluator/EvaluationContext.cpp @@ -126,6 +126,10 @@ void EvaluationContext::storeAssociation_value_(HeapObject *association, Object HeapObject *EvaluationContext::captureClosure_(SBlock *anSBlock) { auto closure = _runtime->newClosureFor_(anSBlock->compiledCode()); + auto home = this->currentCodeIsBlock() ? + (Object*)_runtime->closureHome_(_regE): + (Object*)_runtime->newInteger_(_regBP); + _runtime->closureHome_put_(closure, home); auto it = anSBlock->capturedVariables().begin(); auto i = 1; while(it != anSBlock->capturedVariables().end()) { @@ -200,28 +204,6 @@ void EvaluationContext::stackTemporaryAt_frameIndex_put_(int index, int anotherI _stack[bp - this->tempOffset() - index - 1] = value; } -void EvaluationContext::unwind() -{ - HeapObject* home = _runtime->closureHome_(this->environment()); - if (home == _runtime->_nilObj) - error("cannot return because closure has no home"); - - uintptr_t bp = _regBP; - while (bp != 0) { - HeapObject* environment = _stack[bp - FRAME_TO_ENVIRONMENT_DELTA - 1]->asHeapObject(); - if (environment == home) { - _regBP = bp; - this->popFrame(); - return; - } - - bp = (uintptr_t)_stack[bp - 1]; - } - - error("cannot return from this closure"); - -} - SBinding* EvaluationContext::staticBindingFor_(Object *symbol) { auto b = this->staticBindingForIvar_(symbol); diff --git a/runtime/cpp/Evaluator/EvaluationContext.h b/runtime/cpp/Evaluator/EvaluationContext.h index d1a7c81..dc44ca3 100644 --- a/runtime/cpp/Evaluator/EvaluationContext.h +++ b/runtime/cpp/Evaluator/EvaluationContext.h @@ -56,10 +56,13 @@ class EvaluationContext { uintptr_t stackPointer() { return _regSP; } uintptr_t framePointer() { return _regBP; } + void framePointer_(uintptr_t bp) { _regBP = bp; } Object** stack() { return _stack; } HeapObject* classBinding(); + bool currentCodeIsBlock() { return _runtime->isBlock_(this->_regM); } + int tempOffset() { return 4; } Object* argumentAt_(int anInteger); @@ -224,8 +227,6 @@ class EvaluationContext { _regSP = _regSP - anInteger; } - void unwind(); - Object* temporaryAt_in_(int index, int environmentIndex){ if (environmentIndex == INSTACK_ENVIRONMENT) { return this->stackTemporaryAt_(index); diff --git a/runtime/cpp/Evaluator/Evaluator.cpp b/runtime/cpp/Evaluator/Evaluator.cpp index 5517c1b..8034be5 100644 --- a/runtime/cpp/Evaluator/Evaluator.cpp +++ b/runtime/cpp/Evaluator/Evaluator.cpp @@ -54,7 +54,7 @@ Evaluator::Evaluator(Runtime *runtime, HeapObject *falseObj, HeapObject *trueObj void Evaluator::_halt() { - error("_halt encountered"); + warning("_halt encountered"); } void Evaluator::addPrimitive(const std::string &name, Evaluator::PrimitivePointer primitive) @@ -98,6 +98,7 @@ void Evaluator::initializeUndermessages() { this->addUndermessage("_smiEquals:", &Evaluator::underprimitiveSMIEquals); this->addUndermessage("_identityEquals:", &Evaluator::underprimitiveIdentityEquals); this->addUndermessage("_leadingZeroBitCount", &Evaluator::underprimitiveLeadingZeroBitCount); + this->addUndermessage("_returnTo:", &Evaluator::underprimitiveReturnTo); this->addUndermessage("_quotientTowardZero:", &Evaluator::underprimitiveSMIQuotientTowardZero); this->addUndermessage("_remainderTowardZero:", &Evaluator::underprimitiveSMIRemainderTowardZero); this->addUndermessage("_bitShiftLeft:", &Evaluator::underprimitiveSMIBitShiftLeft); @@ -180,19 +181,16 @@ void Evaluator::initializePrimitives() this->addPrimitive("HostLog", &Evaluator::primitiveHostLog); this->addPrimitive("HostReadFile", &Evaluator::primitiveHostReadFile); - /* - this->addPrimitive("PrepareForExecution", &Evaluator::primitivePrepareForExecution); - this->addPrimitive("ProcessVMStackInitialize", &Evaluator::primitiveProcessVMStackInitialize); - this->addPrimitive("ProcessVMStackAt", &Evaluator::primitiveProcessVMStackAt); - this->addPrimitive("ProcessVMStackAtPut", &Evaluator::primitiveProcessVMStackAtPut); - this->addPrimitive("ProcessVMStackBpAtPut", &Evaluator::primitiveProcessVMStackBpAtPut); - this->addPrimitive("ProcessVMStackPcAtPut", &Evaluator::primitiveProcessVMStackPcAtPut); - */ + + //this->addPrimitive("PrepareForExecution", &Evaluator::primitivePrepareForExecution); + //this->addPrimitive("ProcessVMStackInitialize", &Evaluator::primitiveProcessVMStackInitialize); + this->addPrimitive("ProcessVMStackAt", &Evaluator::primitiveProcessStackAt); + //this->addPrimitive("ProcessVMStackAtPut", &Evaluator::primitiveProcessVMStackAtPut); + //this->addPrimitive("ProcessVMStackBpAtPut", &Evaluator::primitiveProcessVMStackBpAtPut); + //this->addPrimitive("ProcessVMStackPcAtPut", &Evaluator::primitiveProcessVMStackPcAtPut); this->addPrimitive("ProcessVMStackBP", &Evaluator::primitiveProcessBP); - /* - this->addPrimitive("ProcessVMStackBufferSize", &Evaluator::primitiveProcessVMStackBufferSize); - this->addPrimitive("ProcessVMStackContextSwitchTo", &Evaluator::primitiveProcessVMStackContextSwitchTo); - */ + //this->addPrimitive("ProcessVMStackBufferSize", &Evaluator::primitiveProcessVMStackBufferSize); + //this->addPrimitive("ProcessVMStackContextSwitchTo", &Evaluator::primitiveProcessVMStackContextSwitchTo); _linearizer->primitives_(_primitives); } @@ -296,7 +294,7 @@ void Egg::Evaluator::messageNotUnderstood_(SAbstractMessage *message) std::string errmsg = std::string("Message not understood!\n") + this->_regR->printString() + " does not understand " + message->selector()->printString() + "\ndnu recovery not implemented yet"; - + error_(errmsg); } @@ -451,9 +449,8 @@ void Evaluator::visitOpReturn(SOpReturn *anSOpReturn) void Evaluator::visitOpNonLocalReturn(SOpNonLocalReturn *anSOpNonLocalReturn) { - _context->unwind(); - auto code = _runtime->methodExecutableCode_(_context->compiledCode()); - _work = _runtime->executableCodeWork_(code); + _context->push_(_regR); + this->invoke_with_(_runtime->_closureReturnMethod, (Object*)_context->environment()); } void Evaluator::evaluate() { @@ -889,6 +886,11 @@ Object* Evaluator::primitiveProcessBP() return (Object*)this->_runtime->newInteger_(this->_context->framePointer()); } +Object* Evaluator::primitiveProcessStackAt() +{ + return _context->stackAt_(this->_context->firstArgument()->asSmallInteger()->asNative()); +} + Object* Evaluator::primitivePrimeFor() { return this->primitivePrimeFor_(this->_context->firstArgument()->asSmallInteger()->asNative()); } @@ -1276,6 +1278,18 @@ intptr_t Evaluator::underprimitiveLeadingZeroBitCount_(uintptr_t anInteger) { return anInteger < 0 ? 0 : ( std::countl_zero(anInteger)); } +Object* Evaluator::underprimitiveReturnTo(Object* receiver, std::vector& args) +{ + _context->framePointer_(args[0]->asSmallInteger()->asNative()); + this->popFrameAndPrepare(); + /* after returning from underprimitive evaluation, interpreter will try to restore + * stack pointer (args were popped), but in this case we must leave stack as is. To + * avoid the problem, we move the sp further down + */ + _context->reserveStackSlots_(-1); + return receiver; +} + Object* Evaluator::underprimitiveSMIBitAnd(Object *receiver, std::vector &args) { return newIntObject((receiver->asSmallInteger()->asNative() & args[0]->asSmallInteger()->asNative())); } diff --git a/runtime/cpp/Evaluator/Evaluator.h b/runtime/cpp/Evaluator/Evaluator.h index ac72fc8..b61b06e 100644 --- a/runtime/cpp/Evaluator/Evaluator.h +++ b/runtime/cpp/Evaluator/Evaluator.h @@ -230,6 +230,7 @@ class Evaluator : public SExpressionVisitor { Object* primitiveNewSized(); Object* primitivePerformWithArguments(); Object* primitiveProcessBP(); + Object* primitiveProcessStackAt(); Object* primitivePrimeFor(); Object* primitivePrimeFor_(auto anInteger); Object* primitiveSMIBitAnd(); @@ -275,6 +276,7 @@ class Evaluator : public SExpressionVisitor { Object* underprimitiveLargeSize(Object *receiver, std::vector &args); Object* underprimitiveLeadingZeroBitCount(Object *receiver, std::vector &args); intptr_t underprimitiveLeadingZeroBitCount_(uintptr_t anInteger); + Object* underprimitiveReturnTo(Object *receiver, std::vector &args); Object* underprimitiveSMIBitAnd(Object *receiver, std::vector &args); Object* underprimitiveSMIBitOr(Object *receiver, std::vector &args); Object* underprimitiveSMIBitShiftLeft(Object *receiver, std::vector &args); diff --git a/runtime/cpp/Evaluator/Runtime.cpp b/runtime/cpp/Evaluator/Runtime.cpp index f134799..3cbb2cc 100644 --- a/runtime/cpp/Evaluator/Runtime.cpp +++ b/runtime/cpp/Evaluator/Runtime.cpp @@ -29,6 +29,8 @@ Runtime::Runtime(Bootstrapper* bootstrapper, ImageSegment* kernel): void Runtime::initializeEvaluator() { _evaluator = new Evaluator(this, _falseObj, _trueObj, _nilObj); + this->initializeClosureReturnMethod(); + } uintptr_t Runtime::arrayedSizeOf_(Object *anObject) { diff --git a/runtime/cpp/Evaluator/Runtime.h b/runtime/cpp/Evaluator/Runtime.h index 9843620..21a6eff 100644 --- a/runtime/cpp/Evaluator/Runtime.h +++ b/runtime/cpp/Evaluator/Runtime.h @@ -221,6 +221,8 @@ class Runtime { } HeapObject* closureHome_(HeapObject *closure) { + return closure->slot(Offsets::ClosureHome)->asHeapObject(); + /* auto block = this->closureBlock_(closure); if (!this->blockCapturesHome_(block)) error("closure has no home"); @@ -228,8 +230,14 @@ class Runtime { return (this->blockCapturesSelf_(block)) ? closure->slotAt_(_closureInstSize + 2)->asHeapObject() : closure->slotAt_(_closureInstSize + 1)->asHeapObject(); + */ } + void closureHome_put_(HeapObject *closure, Object *anObject) + { + closure->slot(Offsets::ClosureHome) = anObject; + } + HeapObject::ObjectSlot& closureIndexedSlotAt_(HeapObject *closure, int index) { return closure->slotAt_(_closureInstSize + index); } @@ -504,6 +512,13 @@ class Runtime { this->_smallIntegerBehavior = this->speciesInstanceBehavior_(_smallIntegerClass); } + void initializeClosureReturnMethod() + { + auto symbol = this->addSymbol_("return:"); + auto behavior = this->speciesInstanceBehavior_(_closureClass); + this->_closureReturnMethod = this->lookup_startingAt_((Object*)symbol, behavior)->asHeapObject(); + } + HeapObject *_falseObj; HeapObject *_trueObj; HeapObject *_nilObj; @@ -524,6 +539,7 @@ class Runtime { HeapObject *_ephemeronClass; HeapObject *_processStackClass; HeapObject *_symbolTable; + HeapObject *_closureReturnMethod; HeapObject *_smallIntegerBehavior; diff --git a/runtime/cpp/KnownConstants.h b/runtime/cpp/KnownConstants.h index 7cb889a..eacf796 100644 --- a/runtime/cpp/KnownConstants.h +++ b/runtime/cpp/KnownConstants.h @@ -51,6 +51,7 @@ enum Offsets { BlockMethod = 2, ClosureBlock = 0, + ClosureHome = 1, DictionaryTally = 0, DictionaryTable = 1, From 0eb69c44828a0de4aa32f8af13e32b0bec99bfbd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:20:40 -0300 Subject: [PATCH 06/11] [vm-cpp] add doesNotUnderstand support instead of just causing a fatal error --- runtime/cpp/Evaluator/Evaluator.cpp | 29 +++++++++++++++++++++++++---- runtime/cpp/Evaluator/Runtime.cpp | 2 +- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/runtime/cpp/Evaluator/Evaluator.cpp b/runtime/cpp/Evaluator/Evaluator.cpp index 8034be5..8900f6d 100644 --- a/runtime/cpp/Evaluator/Evaluator.cpp +++ b/runtime/cpp/Evaluator/Evaluator.cpp @@ -291,11 +291,32 @@ Object* Evaluator::send_to_with_(Object *symbol, Object *receiver, std::vector_regR->printString() + " does not understand " + message->selector()->printString() + - "\ndnu recovery not implemented yet"; +/* + Having the adaptor causes argument popping work transparently. The adaptor frame's + PC is pointed to the instant after the send, so it just pops the message and continues +*/ + auto count = message->arguments().size(); + std::vector args; + for (size_t i = 1; i <= count; i++) + { + args.push_back(_context->operandAt_(count - i)); + } + auto array = _runtime->newArray_(args); + _context->push_(message->selector()); + _context->push_((Object*)array); + auto symbol = _runtime->addSymbol_("doesNotUnderstand:"); + auto behavior = _runtime->behaviorOf_(_regR); + auto dnu = _runtime->lookup_startingAt_((Object*)symbol, behavior); + if (!dnu) + { + std::string errmsg = std::string("Message not understood!\n") + + this->_regR->printString() + " does not understand " + message->selector()->printString() + + "\nmethod #doesNotUnderstand: not found on receiver"; + error_(errmsg); + + } - error_(errmsg); + this->invoke_with_(dnu->asHeapObject(), _regR); } void Evaluator::doesNotKnow(const Object *symbol) { ASSERT(false); } diff --git a/runtime/cpp/Evaluator/Runtime.cpp b/runtime/cpp/Evaluator/Runtime.cpp index 3cbb2cc..3f1930e 100644 --- a/runtime/cpp/Evaluator/Runtime.cpp +++ b/runtime/cpp/Evaluator/Runtime.cpp @@ -230,7 +230,7 @@ Object* Runtime::lookup_startingAt_(Object *symbol, HeapObject *behavior) auto method = this->doLookup_startingAt_(symbol, behavior); if (!method) - error_(this->behaviorClass_(behavior)->printString() + " does not understand " + symbol->printString()); + return nullptr; auto key = gced_global_cache_key(new GCedRef(symbol),new GCedRef((Object*)behavior)); auto value = new GCedRef((Object*)method); _globalCache.insert({key, value}); From 59aefa2495ef5d536c1e77cf48436e1f538a0802 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:21:50 -0300 Subject: [PATCH 07/11] [vm-cpp] fix linearization of empty block treecodes (return op at the end was missing) --- runtime/cpp/Evaluator/SExpressionLinearizer.cpp | 1 + 1 file changed, 1 insertion(+) diff --git a/runtime/cpp/Evaluator/SExpressionLinearizer.cpp b/runtime/cpp/Evaluator/SExpressionLinearizer.cpp index b1a4d89..76bb6df 100644 --- a/runtime/cpp/Evaluator/SExpressionLinearizer.cpp +++ b/runtime/cpp/Evaluator/SExpressionLinearizer.cpp @@ -453,6 +453,7 @@ void SExpressionLinearizer::visitBlock(SBlock *anSBlock) { if (statements.empty()) { this->loadRwithNil(); + this->returnOp(); } else { if (!statements.back()->isReturn()) this->returnOp(); From ab0cbf004e0f13b44e97014f10641b9f1718006a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:31:16 -0300 Subject: [PATCH 08/11] [kernel] add printOn: in MNU class --- modules/Kernel/MessageNotUnderstood.st | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/modules/Kernel/MessageNotUnderstood.st b/modules/Kernel/MessageNotUnderstood.st index 2444fd0..1a033b5 100644 --- a/modules/Kernel/MessageNotUnderstood.st +++ b/modules/Kernel/MessageNotUnderstood.st @@ -53,6 +53,18 @@ MessageNotUnderstood >> message: aMessage [ message := aMessage ] +{ #category : #accessing } +MessageNotUnderstood >> printOn: aStream [ + aStream nextPutAll: self class name withArticle. + message ifNotNil: [ + aStream + cr; nextPutAll: 'selector: '; print: message selector; + cr; nextPutAll: 'arguments: '; print: message arguments]. + receiver ifNotNil: [ + aStream cr; nextPutAll: 'receiver: '; print: receiver]. + aStream cr. +] + { #category : #accessing } MessageNotUnderstood >> receiver [ ^receiver From 371fa0f0392807d45be89532a6d71148cb6a10b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:34:59 -0300 Subject: [PATCH 09/11] [vm-pharo] implement ensure support, which required changing closure non-local return unwinding --- .../Powerlang-Core/EggBootstrapImage.class.st | 7 +++- .../EggBootstrapRuntime.class.st | 36 +++++++++++++++++++ .../Powerlang-Core/EggEvaluator.class.st | 15 +++++++- .../EggIterativeStackedInterpreter.class.st | 7 ++-- .../EggMetacircularRuntime.class.st | 23 +++++++++++- .../pharo/Powerlang-Core/EggRuntime.class.st | 8 ++++- .../Powerlang-Core/EvaluationContext.class.st | 7 +++- .../Ring2MetacircularConverter.class.st | 6 +++- .../StackedEvaluationContext.class.st | 15 -------- 9 files changed, 99 insertions(+), 25 deletions(-) diff --git a/runtime/pharo/Powerlang-Core/EggBootstrapImage.class.st b/runtime/pharo/Powerlang-Core/EggBootstrapImage.class.st index 424a19f..0e06d9c 100644 --- a/runtime/pharo/Powerlang-Core/EggBootstrapImage.class.st +++ b/runtime/pharo/Powerlang-Core/EggBootstrapImage.class.st @@ -141,7 +141,7 @@ EggBootstrapImage >> newInteger: anInteger [ ifTrue: [ ^ self newLargePositiveInteger: anInteger ]. anInteger < minSMI ifTrue: [ ^ self newLargeNegativeInteger: anInteger ]. - ^ ProtoeggSmallInteger new: smiSpec valued: anInteger + ^ self newSmallInteger: anInteger ] { #category : 'initialization' } @@ -169,6 +169,11 @@ EggBootstrapImage >> newLargePositiveInteger: anInteger [ ^ self newBytes: #LargePositiveInteger contents: bytes ] +{ #category : 'initialization' } +EggBootstrapImage >> newSmallInteger: anInteger [ + ^ProtoeggSmallInteger new: smiSpec valued: anInteger +] + { #category : 'initialization' } EggBootstrapImage >> newString: aString [ | bytes | diff --git a/runtime/pharo/Powerlang-Core/EggBootstrapRuntime.class.st b/runtime/pharo/Powerlang-Core/EggBootstrapRuntime.class.st index 56c5598..6cb0a21 100644 --- a/runtime/pharo/Powerlang-Core/EggBootstrapRuntime.class.st +++ b/runtime/pharo/Powerlang-Core/EggBootstrapRuntime.class.st @@ -90,6 +90,28 @@ EggBootstrapRuntime >> closureHomeEnvironment: closure [ ^ closure slotAt: 2 ] +{ #category : 'services' } +EggBootstrapRuntime >> closureHomeFrame: closure [ + + ^ closure homeFrame +] + +{ #category : 'services' } +EggBootstrapRuntime >> closureHomeFrame: closure put: anObject [ + + ^ closure homeFrame: anObject +] + +{ #category : 'accessing' } +EggBootstrapRuntime >> closureReturnMethod [ + | species smethod method | + ^closureReturnMethod ifNil: [ + species := image classNamed: #Closure. + smethod := species instanceSpec >> #return:. + method := self compile: smethod. + closureReturnMethod := self transferMethodLiterals: method] +] + { #category : 'accessing' } EggBootstrapRuntime >> compile: method [ | class | @@ -347,6 +369,11 @@ EggBootstrapRuntime >> newSlotsOf: aProtoeggSpecies [ ^image newSlotsOf: aProtoeggSpecies spec instanceSide sized: 0 ] +{ #category : 'accessing' } +EggBootstrapRuntime >> newSmallInteger: anInteger [ + ^image newSmallInteger: anInteger +] + { #category : 'services' } EggBootstrapRuntime >> newSymbol: aSymbol [ ^ image newSymbol: aSymbol @@ -386,6 +413,15 @@ EggBootstrapRuntime >> override: assoc withPrimitive: primitive [ overrides at: species -> selector put: override ] +{ #category : 'accessing' } +EggBootstrapRuntime >> realClosureReturnMethod [ + | species selector | + species := image classNamed: #Closure. + selector := image newSymbol: #return:. + ^self sendLocal: #at: to: species instanceBehavior methods with: {selector}. + +] + { #category : 'accessing' } EggBootstrapRuntime >> removeBootstrapDictionaryOverrides [ self diff --git a/runtime/pharo/Powerlang-Core/EggEvaluator.class.st b/runtime/pharo/Powerlang-Core/EggEvaluator.class.st index 17c5f4d..06e98b6 100644 --- a/runtime/pharo/Powerlang-Core/EggEvaluator.class.st +++ b/runtime/pharo/Powerlang-Core/EggEvaluator.class.st @@ -248,6 +248,7 @@ EggEvaluator >> initializeUndermessages [ at: #_byteAt:put: put: self underprimitiveByteAtPut; at: #_basicHash put: self underprimitiveBasicHash; at: #_basicHash: put: self underprimitiveBasicHashPut; + at: #_returnTo: put: self underprimitiveReturnTo; at: #_smallIntegerByteAt: put: self underprimitiveSmallIntegerByteAt; at: #_bitShiftLeft: put: self underprimitiveBitShiftLeft; @@ -585,7 +586,7 @@ EggEvaluator >> primitiveProcessVMStackInitialize [ | new | new := stacks isEmpty ifTrue: [ context ] - ifFalse: [ self newEvaluationContext ]. + ifFalse: [ self halt newEvaluationContext ]. stacks at: context self put: new ] ] @@ -912,6 +913,18 @@ EggEvaluator >> underprimitiveLeadingZeroBitCount: anInteger [ ifFalse: [ runtime wordSize * 8 - anInteger highBit ] ] +{ #category : 'accessing' } +EggEvaluator >> underprimitiveReturnTo [ + ^ [ :receiver :arguments | + context regBP: arguments first value. + self popFrameAndPrepare. + "after returning from underprimitive evaluation, interpreter will try to restore + stack pointer (args were popped), but in this case we must leave stack as is. To + avoid the problem, we move the sp further down" + context reserveStackSlots: -1. + receiver] +] + { #category : 'accessing' } EggEvaluator >> underprimitiveSMIBitAnd [ ^ [ :receiver :arguments | runtime newInteger: (receiver value bitAnd: arguments first value) ] diff --git a/runtime/pharo/Powerlang-Core/EggIterativeStackedInterpreter.class.st b/runtime/pharo/Powerlang-Core/EggIterativeStackedInterpreter.class.st index 7dbd787..5b18a6e 100644 --- a/runtime/pharo/Powerlang-Core/EggIterativeStackedInterpreter.class.st +++ b/runtime/pharo/Powerlang-Core/EggIterativeStackedInterpreter.class.st @@ -90,6 +90,7 @@ EggIterativeStackedInterpreter >> initializePrimitives [ { #category : 'initialization' } EggIterativeStackedInterpreter >> invoke: method with: receiver [ | size environment | + (runtime methodNeedsEnvironment: method) ifTrue: [ size := runtime methodEnvironmentSize: method. @@ -246,10 +247,8 @@ EggIterativeStackedInterpreter >> visitOpJumpTrue: anSOpJumpTrue [ { #category : 'initialization' } EggIterativeStackedInterpreter >> visitOpNonLocalReturn: anSOpReturn [ - | code | - context unwind. - code := runtime methodExecutableCode: context regM. - work := runtime executableCodeWork: code + context push: regR. + self invoke: runtime closureReturnMethod with: context environment ] { #category : 'initialization' } diff --git a/runtime/pharo/Powerlang-Core/EggMetacircularRuntime.class.st b/runtime/pharo/Powerlang-Core/EggMetacircularRuntime.class.st index 9556ca2..93e09e6 100644 --- a/runtime/pharo/Powerlang-Core/EggMetacircularRuntime.class.st +++ b/runtime/pharo/Powerlang-Core/EggMetacircularRuntime.class.st @@ -44,7 +44,8 @@ Class { 'compiledCodeExecutableCodeIndex', 'floatClass', 'processStackSPIndex', - 'ffiMethodClass' + 'ffiMethodClass', + 'closureHomeFrameIndex' ], #pools : [ 'SCompiledBlockFlags', @@ -259,6 +260,26 @@ EggMetacircularRuntime >> closureHome: closure [ ifFalse: [ closure at: 1 ] ] +{ #category : 'initialization' } +EggMetacircularRuntime >> closureHomeFrame: closure [ + ^closure slotAt: closureHomeFrameIndex +] + +{ #category : 'initialization' } +EggMetacircularRuntime >> closureHomeFrame: closure put: value [ + closure slotAt: closureHomeFrameIndex put: value +] + +{ #category : 'initialization' } +EggMetacircularRuntime >> closureHomeFrameIndex: anInteger [ + closureHomeFrameIndex := anInteger +] + +{ #category : 'initialization' } +EggMetacircularRuntime >> closureReturnMethod: anEggObject [ + closureReturnMethod := anEggObject +] + { #category : 'initialization' } EggMetacircularRuntime >> dictionaryTable: anLMRObject [ ^anLMRObject slotAt: dictionaryTableIndex diff --git a/runtime/pharo/Powerlang-Core/EggRuntime.class.st b/runtime/pharo/Powerlang-Core/EggRuntime.class.st index eb7b397..8ad8f5f 100644 --- a/runtime/pharo/Powerlang-Core/EggRuntime.class.st +++ b/runtime/pharo/Powerlang-Core/EggRuntime.class.st @@ -9,7 +9,8 @@ Class { 'interpreter', 'overrides', 'symbolCache', - 'doesNotUnderstandMethod' + 'doesNotUnderstandMethod', + 'closureReturnMethod' ], #pools : [ 'ClosureElementTypes' @@ -47,6 +48,11 @@ EggRuntime >> booleanFrom: anObject [ self error: 'not a boolean' ] +{ #category : 'initialization' } +EggRuntime >> closureReturnMethod [ + ^closureReturnMethod +] + { #category : 'initialization' } EggRuntime >> doesNotUnderstandMethod [ diff --git a/runtime/pharo/Powerlang-Core/EvaluationContext.class.st b/runtime/pharo/Powerlang-Core/EvaluationContext.class.st index 659ab0d..3597b31 100644 --- a/runtime/pharo/Powerlang-Core/EvaluationContext.class.st +++ b/runtime/pharo/Powerlang-Core/EvaluationContext.class.st @@ -34,8 +34,13 @@ EvaluationContext >> backtrace [ { #category : 'visiting' } EvaluationContext >> captureClosure: anSBlock [ - | closure s i type env arg | + | closure home s i type env arg | closure := runtime newClosureFor: anSBlock compiledCode. + home := self isBlock + ifTrue: [ runtime closureHomeFrame: self environment] + ifFalse: [ runtime newInteger: self regBP ]. + runtime closureHomeFrame: closure put: home. + s := anSBlock capturedVariables readStream. i := 1. [ s atEnd ] diff --git a/runtime/pharo/Powerlang-Core/Ring2MetacircularConverter.class.st b/runtime/pharo/Powerlang-Core/Ring2MetacircularConverter.class.st index 09cb6b5..28840ca 100644 --- a/runtime/pharo/Powerlang-Core/Ring2MetacircularConverter.class.st +++ b/runtime/pharo/Powerlang-Core/Ring2MetacircularConverter.class.st @@ -409,6 +409,8 @@ Ring2MetacircularConverter >> image: aPowertalkRingImage [ dest dictionaryTableIndex: index. index := (source => #Closure) allInstVarNames indexOf: 'block'. dest closureBlockIndex: index. + index := (source => #Closure) allInstVarNames indexOf: 'homeFrame'. + dest closureHomeFrameIndex: index. index := (source => #CompiledBlock) allInstVarNames indexOf: 'method'. dest blockMethodIndex: index. index := (source => #CompiledMethod) allInstVarNames indexOf: @@ -474,7 +476,7 @@ Ring2MetacircularConverter >> initializeEmulationOverrides [ { #category : 'initialization' } Ring2MetacircularConverter >> initializeRuntime [ - | map symbols array method smi block metaclass kernel byteArray string closure behavior lpi lni float dnu | + | map symbols array method smi block metaclass kernel byteArray string closure behavior lpi lni float dnu return | symbols := Dictionary new. #( + - < > <= >= = == not ) do: [ :symbol | map := source newSymbol: symbol. @@ -492,6 +494,7 @@ Ring2MetacircularConverter >> initializeRuntime [ string := mapping at: (source classNamed: #String). metaclass := mapping at: (source classNamed: #Metaclass). dnu := mapping at: source runtime doesNotUnderstandMethod. + return := mapping at: source runtime realClosureReturnMethod. kernel := mapping at: source kernel. dest arrayClass: array; @@ -508,6 +511,7 @@ Ring2MetacircularConverter >> initializeRuntime [ metaclassClass: metaclass; knownSymbols: symbols; doesNotUnderstandMethod: dnu; + closureReturnMethod: return; wordSize: source wordSize; initializeInterpreter; kernel: kernel. diff --git a/runtime/pharo/Powerlang-Core/StackedEvaluationContext.class.st b/runtime/pharo/Powerlang-Core/StackedEvaluationContext.class.st index bbb0b85..5aaf6b5 100644 --- a/runtime/pharo/Powerlang-Core/StackedEvaluationContext.class.st +++ b/runtime/pharo/Powerlang-Core/StackedEvaluationContext.class.st @@ -521,18 +521,3 @@ StackedEvaluationContext >> temporaryAt: index in: environmentIndex put: value [ StackedEvaluationContext >> thirdArgument [ ^ self argumentAt: 3 ] - -{ #category : 'initialization' } -StackedEvaluationContext >> unwind [ - | home bp environment | - home := runtime closureHome: self environment. - home == runtime nil ifTrue: [ self error: 'cannot return because closure has no home' ]. - bp := regBP. - [ bp != 0 ] - whileTrue: [ environment := stack at: bp - 4. - environment == home - ifTrue: [ regBP := bp. - ^ self popFrame ]. - bp := stack at: bp ]. - self error: 'cannot return from this closure' -] From 69329e4b13f5d7dd7b04383a0ee4d267dd8a1cbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:36:03 -0300 Subject: [PATCH 10/11] [vm-pharo] fix treecode linearization of empty block, which needs a return op after loading R with nil --- runtime/pharo/Powerlang-Core/SExpressionLinearizer.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/runtime/pharo/Powerlang-Core/SExpressionLinearizer.class.st b/runtime/pharo/Powerlang-Core/SExpressionLinearizer.class.st index 6fe8f48..9f78844 100644 --- a/runtime/pharo/Powerlang-Core/SExpressionLinearizer.class.st +++ b/runtime/pharo/Powerlang-Core/SExpressionLinearizer.class.st @@ -498,7 +498,7 @@ SExpressionLinearizer >> visitBlock: anSBlock [ statements := anSBlock statements. statements do: [ :node | node acceptVisitor: self ]. statements isEmpty - ifTrue: [ self loadRwithNil ] + ifTrue: [ self loadRwithNil; return ] ifFalse: [ statements last isReturn ifFalse: [ self return ] ]. anSBlock isInlined ifFalse: [ code := runtime newExecutableCodeFor: operations asArray. From 95fc2ced5b78fcbc2c93e55c6b874c3bc70d63bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Pim=C3=A1s?= Date: Tue, 10 Jun 2025 23:53:26 -0300 Subject: [PATCH 11/11] [vm-pharo] make non-local return tests run bootstrap to init Processor activeProcess, which is needed to check for ensured blocks --- .../pharo/Powerlang-Tests/EggBootstrapRuntimeTest.class.st | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/runtime/pharo/Powerlang-Tests/EggBootstrapRuntimeTest.class.st b/runtime/pharo/Powerlang-Tests/EggBootstrapRuntimeTest.class.st index 8b8b897..316c47d 100644 --- a/runtime/pharo/Powerlang-Tests/EggBootstrapRuntimeTest.class.st +++ b/runtime/pharo/Powerlang-Tests/EggBootstrapRuntimeTest.class.st @@ -412,6 +412,9 @@ EggBootstrapRuntimeTest >> test164evaluateClosureWithArgsAndMultipleTemps [ { #category : 'tests' } EggBootstrapRuntimeTest >> test165evaluateClosureNonLocalReturn [ | result | + "need to run bootstrap to be able to unwind, because it sends message to + Processor to check for ensured blocks" + image bootstrap. self compile: 'foo @@ -447,6 +450,7 @@ EggBootstrapRuntimeTest >> test167evaluateNestedClosureWithArgs [ { #category : 'tests' } EggBootstrapRuntimeTest >> test168evaluateNestedClosureNonLocalReturn [ | result | + image bootstrap. self compile: 'foo [ [ ^7 ] value ] value' in: #ProtoObject