Fix the creation of an exception context [feenkcom/gtoolkit#3942]

feenkcom · Aug 6, 2024 · 7f4699b · 7f4699b
1 parent 2b8d22c
commit 7f4699b
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 17 deletions.
diff --git a/src/GToolkit-GemStone-GemStone/GtGemStoneEvaluationContext.class.st b/src/GToolkit-GemStone-GemStone/GtGemStoneEvaluationContext.class.st
@@ -34,6 +34,11 @@ GtGemStoneEvaluationContext >> assertNotSignalled [
 		[ self error: 'Process semaphore already signalled' ]
 ]
 
+{ #category : 'accessing' }
+GtGemStoneEvaluationContext >> block [
+	^ block
+]
+
 { #category : 'accessing' }
 GtGemStoneEvaluationContext >> buildMessageText [
 
@@ -181,9 +186,15 @@ GtGemStoneEvaluationContext >> handlerBlock: anObject [
 	If the user resumes the process it will then resume from where the exception was originally raised."
 
 	^ [ :ex |
-		result := self asGtEvaluationExceptionContext asGtRsrProxyObjectForConnection: evalServer _connection.
+		| newExceptionContext |
+
 		exception := ex.
 		devMessage := anObject.
+
+		newExceptionContext := self asGtEvaluationExceptionContext.
+		result := newExceptionContext asGtRsrProxyObjectForConnection: evalServer _connection.
+		newExceptionContext result: result.
+
 		semaphore signal.
 		process suspend.
 		ex resume ]
@@ -195,14 +206,13 @@ GtGemStoneEvaluationContext >> initializeFromContext: aGtGemStoneEvaluationConte
 	process := aGtGemStoneEvaluationContext process.
 	serializationStrategy :=aGtGemStoneEvaluationContext serializationStrategy.
 	result := aGtGemStoneEvaluationContext result.
-	completed := aGtGemStoneEvaluationContext completed.
+	completed := aGtGemStoneEvaluationContext isCompleted.
 	devMessage :=aGtGemStoneEvaluationContext devMessage.
 	evalServer := aGtGemStoneEvaluationContext evalServer.
 	block :=aGtGemStoneEvaluationContext block.
-	callStack := aGtGemStoneEvaluationContext callStack.
+	semaphore :=aGtGemStoneEvaluationContext semaphore.
 
-	"We just signal it in the initial context. Normally should not be needed anymore"
-	"semaphore :=aGtGemStoneEvaluationContext semaphore."
+	"callStack := aGtGemStoneEvaluationContext callStack."
 ]
 
 { #category : 'testing' }
@@ -281,6 +291,16 @@ GtGemStoneEvaluationContext >> restartFrameLevel: anInteger [
 	^ #restart
 ]
 
+{ #category : 'accessing' }
+GtGemStoneEvaluationContext >> result [
+	^ result
+]
+
+{ #category : 'accessing' }
+GtGemStoneEvaluationContext >> result: aResult [
+	result := aResult
+]
+
 { #category : 'actions - debug' }
 GtGemStoneEvaluationContext >> resume [
 
@@ -290,6 +310,11 @@ GtGemStoneEvaluationContext >> resume [
 	^ result
 ]
 
+{ #category : 'accessing' }
+GtGemStoneEvaluationContext >> semaphore [
+	^ semaphore
+]
+
 { #category : 'accessing' }
 GtGemStoneEvaluationContext >> serializationStrategy [
 	^serializationStrategy

diff --git a/src/GToolkit-GemStone-GemStone/GtRsrEvaluatorServiceServer.class.st b/src/GToolkit-GemStone-GemStone/GtRsrEvaluatorServiceServer.class.st
@@ -34,7 +34,7 @@ GtRsrEvaluatorServiceServer >> evaluateReturnProxy: aString for: anObject bindin
 
 { #category : 'private - GemStone' }
 GtRsrEvaluatorServiceServer >> gsEvaluate: aString for: anObject bindings: aDictionary [
-	^ self evaluate: aString for: anObject bindings: aDictionary serializationStrategy: nil
+	^ self gsEvaluate: aString for: anObject bindings: aDictionary serializationStrategy: nil
 ]
 
 { #category : 'private - GemStone' }

diff --git a/src/GToolkit-GemStone-GemStone/GtRsrEvaluatorServiceTest.class.st b/src/GToolkit-GemStone-GemStone/GtRsrEvaluatorServiceTest.class.st
@@ -1,16 +1,16 @@
 Class {
-	#name : #GtRsrEvaluatorServiceTest,
-	#superclass : #TestCase,
+	#name : 'GtRsrEvaluatorServiceTest',
+	#superclass : 'TestCase',
 	#category : 'GToolkit-GemStone-GemStone'
 }
 
-{ #category : #private }
+{ #category : 'private' }
 GtRsrEvaluatorServiceTest >> gsErrorClass [
 
 	^ CompileError
 ]
 
-{ #category : #private }
+{ #category : 'private' }
 GtRsrEvaluatorServiceTest >> should: testBlock raise: anErrorClass withExceptionDo: exceptionBlock [
 
 	testBlock
@@ -21,7 +21,7 @@ GtRsrEvaluatorServiceTest >> should: testBlock raise: anErrorClass withException
 	self error: anErrorClass printString, ' not raised'.
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testCompilationError [
 	"Confirm that a compilation error is caught and returned in"
 	| script evaluator context |
@@ -35,7 +35,7 @@ GtRsrEvaluatorServiceTest >> testCompilationError [
 	self assert: context exception messageText = 'a CompileError occurred (error 1001), expected a primary expression '.
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testInitialState [
 	"Check that the initial state answers the expected information"
 	| process exception state encodedState deserializedState contextSpecification |
@@ -78,7 +78,7 @@ GtRsrEvaluatorServiceTest >> testInitialState [
 	self deny: deserializedState isTerminated.
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testProxiedObjectScript [
 	"Test answering a complex object.
 	Assumes that Associations are not immediate"
@@ -109,7 +109,7 @@ anArray.'.
 	^ result.
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testRuntimeErrorScript [
 	| script evaluator result object |
 
@@ -119,12 +119,12 @@ GtRsrEvaluatorServiceTest >> testRuntimeErrorScript [
 	result := evaluator evaluate: script for: 4 bindings: Dictionary new.
 	self assert: result class = GtRsrProxyServiceServer.
 	object := result object.
-	self assert: object class = GtGemStoneEvaluationContext.
+	self assert: object class = GtGemStoneEvaluationExceptionContext.
 	"Pharo raises #adaptToNumber:andSend:, GemStone raises #_generality"
 	self assert: (#(#adaptToNumber:andSend: #'_generality') includes: object exception message selector).
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testSelfScript [
 	| script evaluator result |
 
@@ -134,7 +134,7 @@ GtRsrEvaluatorServiceTest >> testSelfScript [
 	self assert: result equals: 7.
 ]
 
-{ #category : #tests }
+{ #category : 'tests' }
 GtRsrEvaluatorServiceTest >> testSimpleScript [
 	| script evaluator result |