Jp/sunit and friends

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,19 +65,56 @@ 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.
 	aMessage evaluate.
 	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 [

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 |

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

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

modules/Kernel/Process.st

@@ -109,6 +109,7 @@ Process >> name: aString [
 
 { #category : #accessing }
 Process >> nativeStack [
+	nativeStack ifNil: [self initializeStack].
 	^nativeStack
 ]
 

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.

modules/Kernel/VM/Float.st

@@ -66,9 +66,9 @@ Float >> < aNumber [
 Float >> = aNumber [
 	| nan status |
 	<primitive: FloatEqual>
-	status := Float status.
 	^aNumber isFloat
 		ifTrue: [
+			status := Float status.
 			nan := self isNaN.
 			(nan and: [aNumber isNaN]) ifTrue: [^true].
 			(nan or: [aNumber isNaN]) ifTrue: [^false].

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.
+]
+

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
+]
+

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]]]
+]
+

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
+]
+

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]
+]
+

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
+]
+

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'
+]
+

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
+]
+