25 interpret does not recognize pragma arguments

DebuggableASTInterpreter/DASTInterpreter.class.st

@@ -216,28 +216,34 @@ DASTInterpreter >> restart: aDASTContext [
 
 { #category : #private }
 DASTInterpreter >> solvePrimitive: aMethod receiver: anObject arguments: anArray [
+
 	| primitiveResult anInteger |
 	anInteger := aMethod primitive.
-
 	"primitives applied to blocks:"
 	(anObject isKindOf: DASTClosure) ifTrue: [ 
-		anInteger = 266 ifTrue: [
-			self halt. 
-			^self stackPush: anObject argumentCount. 
-		 ].
+		anInteger = 266 ifTrue: [ 
+			self halt.
+			^ self stackPush: anObject argumentCount ].
 		anInteger = 202 ifTrue: [ 
 			self halt.
-			primitiveResult := anObject tryPrimitive: anInteger withArgs: anArray asArray.
-			^ self stackPush: primitiveResult
-		].
-		DASTPrimitiveFailed signalWithPrimitive: anInteger receiver: anObject 
-	].
+			primitiveResult := anObject
+				                   tryPrimitive: anInteger
+				                   withArgs: anArray asArray.
+			^ self stackPush: primitiveResult ].
+		DASTPrimitiveFailed
+			signalWithPrimitive: anInteger
+			receiver: anObject ].
 	"apply primitive to object"
-	primitiveResult := self evaluator executePrimitiveMethod: aMethod withReceiver: anObject withArguments: anArray asArray.
-	(self evaluator primitiveResultIsError: primitiveResult)
-		ifTrue: [ DASTPrimitiveFailed signalWithPrimitive: anInteger receiver: anObject ].
+	primitiveResult := self evaluator
+		                   executePrimitiveMethod: aMethod
+		                   withReceiver: anObject
+		                   withArguments: anArray asArray.
+	(self evaluator primitiveResultIsError: primitiveResult) ifTrue: [ 
+		DASTPrimitiveFailed
+			signalWithPrimitive: anInteger
+			receiver: anObject
+			errorCode: primitiveResult second ].
 	self stackPush: (self evaluator valueOf: primitiveResult)
-
 ]
 
 { #category : #stack }
@@ -407,41 +413,55 @@ DASTInterpreter >> visitLiteralVariableNode: aRBVariableNode [
 ]
 
 { #category : #visiting }
-DASTInterpreter >> visitMessageNode: aRBMessageNode [ 
-	| arguments receiver method newContext |
-	" Resolve Arguments "
+DASTInterpreter >> visitLocalVariableNode: aNode [
+
+	"call visitTemporaryNode: for backward compatibility"
+
+	^ self visitTemporaryNode: aNode
+]
+
+{ #category : #visiting }
+DASTInterpreter >> visitMessageNode: aRBMessageNode [
 
-	"self haltIf: [ aRBMessageNode selector = #methodDict ]."
-	arguments := (self stackPop: aRBMessageNode numArgs) reverse.	
-	(aRBMessageNode isCascaded and: [aRBMessageNode isFirstCascaded not]) ifTrue: [ self stackPop ].
+	| arguments receiver method newContext |
+	" Resolve Arguments ""self haltIf: [ aRBMessageNode selector = #methodDict ]."
+	arguments := (self stackPop: aRBMessageNode numArgs) reverse.
+	(aRBMessageNode isCascaded and: [ aRBMessageNode isFirstCascaded not ]) 
+		ifTrue: [ self stackPop ].
 	receiver := self stackPop.
-	
+
 	" Current context initialization (implicit lookup)"
-	newContext := 
-		DASTContext
-			newWithSender: self currentContext 
-			receiver: receiver 
-			messageNode: aRBMessageNode
-			evaluator: self evaluator.
-
+	newContext := DASTContext
+		              newWithSender: self currentContext
+		              receiver: receiver
+		              messageNode: aRBMessageNode
+		              evaluator: self evaluator.
+
 	" Lookup"
 	method := newContext methodOrBlock.
 	" Apply - invoke method "
-	(aRBMessageNode isCascaded and: [aRBMessageNode parent messages last ~= aRBMessageNode]) ifTrue: [ self stackPush: receiver ]. 
-	(method isPrimitive and: [method isMessageValue not and: [method isOnDo not]] )  
-	ifTrue: [ 
-		[ ^ self solvePrimitive: method receiver: receiver arguments: arguments ]
-		on: DASTPrimitiveFailed 
-		do: [ 
-			" Remove pragma node from method body to prevent infinit loop 
+	(aRBMessageNode isCascaded and: [ 
+		 aRBMessageNode parent messages last ~= aRBMessageNode ]) ifTrue: [ 
+		self stackPush: receiver ].
+	(method isPrimitive and: [ 
+		 method isMessageValue not and: [ method isOnDo not ] ]) ifTrue: [ 
+		[ 
+		^ self
+			  solvePrimitive: method
+			  receiver: receiver
+			  arguments: arguments ]
+			on: DASTPrimitiveFailed
+			do: [ :failure | " Remove pragma node from method body to prevent infinit loop 
 			  and continue with the excecution of the method body"
-			  newContext := newContext removePrimitiveFromMethod;yourself.
-			]
-		].
+				newContext := newContext
+					              removePrimitiveFromMethod;
+					              yourself.
+				newContext stack push: failure errorCode ] ].
 	" Set new context "
 	currentContext := newContext.
-	currentContext setTemporalVariablesNamed: method argumentNames values: arguments.
-
+	currentContext
+		setTemporalVariablesNamed: method argumentNames
+		values: arguments
 ]
 
 { #category : #visiting }
@@ -450,6 +470,15 @@ DASTInterpreter >> visitMethodNode: aRBBlockNode [
 
 
 
+]
+
+{ #category : #visiting }
+DASTInterpreter >> visitPragmaNode: aRBPragmaNode [
+
+	aRBPragmaNode isPrimitiveError ifFalse: [ ^ self ].
+	self currentContext
+		at: aRBPragmaNode primitiveErrorVariableName
+		put: self stackTop
 ]
 
 { #category : #visiting }

DebuggableASTInterpreter/DASTInterpreterTests.class.st

@@ -253,6 +253,23 @@ DASTInterpreterTests >> testExecutedNodesAtExecutionStart [
 	self assert: interpreter currentContext executedNodes isEmpty
 ]
 
+{ #category : #'tests-primitives' }
+DASTInterpreterTests >> testFailingPrimitiveWithErrorCode [
+
+	interpreter initializeWithProgram:
+		(RBParser parseExpression: '1 become: 2').
+	"We step until the primitive failure, which returns an error code"
+	8 timesRepeat: [ interpreter stepInto ].
+
+	self assert: interpreter stackTop equals: 'inappropriate operation'.
+
+	"One more step will interpret the pragma node <primitive:error:> that should put the error code in the primitive error variable. In this case, this variable is called 'ec'"
+	interpreter stepInto.
+	self
+		assert: (interpreter currentContext findVariable: 'ec')
+		equals: 'inappropriate operation'
+]
+
 { #category : #'tests-primitives' }
 DASTInterpreterTests >> testFalse [
 	self assert: (self evaluateProgram: 'false')

DebuggableASTInterpreter/DASTMethodContext.class.st

@@ -50,7 +50,7 @@ DASTMethodContext >> initializeContext [
 	compiledMethod := self lookupSelector: aSelector startInClass: aClass.
 	ast := DASTMethod new initializeWith: compiledMethod ast evaluator: self evaluator. 
 	visitor := DASTPostOrderTreeVisitor new.
-	ast body acceptVisitor: visitor.
+	ast nodeAST acceptVisitor: visitor.
 	flatNodes := visitor stack.
 
 	self 	methodOrBlock: ast;

DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st

@@ -38,7 +38,7 @@ DASTPostOrderTreeVisitor >> visitArgumentNode: aRBArgumentNode [
 ]
 
 { #category : #visiting }
-DASTPostOrderTreeVisitor >> visitArgumentVariableNode: aRBVariableNode [
+DASTPostOrderTreeVisitor >> visitArgumentVariableNode: aRBVariableNode [ 
 
 	^ self visitTemporaryNode: aRBVariableNode
 ]
@@ -113,6 +113,14 @@ DASTPostOrderTreeVisitor >> visitLiteralVariableNode: aRBVariableNode [
 	^ self visitGlobalNode: aRBVariableNode
 ]
 
+{ #category : #visiting }
+DASTPostOrderTreeVisitor >> visitLocalVariableNode: aNode [
+
+	"call visitTemporaryNode: for backward compatibility"
+
+	^ self visitTemporaryNode: aNode
+]
+
 { #category : #visiting }
 DASTPostOrderTreeVisitor >> visitMessageNode: aRBMessageNode [ 
 
@@ -126,10 +134,16 @@ DASTPostOrderTreeVisitor >> visitMessageNode: aRBMessageNode [
 ]
 
 { #category : #visiting }
-DASTPostOrderTreeVisitor >> visitMethodNode: aRBMethodNode [ 
-
-	stack push: aRBMethodNode.
+DASTPostOrderTreeVisitor >> visitMethodNode: aRBMethodNode [
+
 	aRBMethodNode body acceptVisitor: self.
+	aRBMethodNode pragmas do: [ :each | each acceptVisitor: self ]
+]
+
+{ #category : #visiting }
+DASTPostOrderTreeVisitor >> visitPragmaNode: aRBPragmaNode [
+
+	stack push: aRBPragmaNode
 ]
 
 { #category : #visiting }
@@ -157,7 +171,7 @@ DASTPostOrderTreeVisitor >> visitSuperNode: aRBSuperNode [
 	^ stack push: aRBSuperNode
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #visiting }
 DASTPostOrderTreeVisitor >> visitTemporaryNode: aRBTemporaryNode [ 
 	stack push: aRBTemporaryNode
 ]

DebuggableASTInterpreter/DASTPrimitiveFailed.class.st

@@ -3,7 +3,8 @@ Class {
 	#superclass : #Error,
 	#instVars : [
 		'primitiveNumber',
-		'receiver'
+		'receiver',
+		'errorCode'
 	],
 	#category : #'DebuggableASTInterpreter-Exceptions'
 }
@@ -16,11 +17,44 @@ DASTPrimitiveFailed class >> primitiveNumber: anInteger receiver: anObject [
 		yourself
 ]
 
+{ #category : #signaling }
+DASTPrimitiveFailed class >> primitiveNumber: anInteger receiver: anObject errorCode: ec [
+
+	^ (self primitiveNumber: anInteger receiver: anObject)
+		  errorCode: ec;
+		  yourself
+]
+
 { #category : #signaling }
 DASTPrimitiveFailed class >> signalWithPrimitive: anInteger receiver: anObject [
 	^(self primitiveNumber: anInteger receiver: anObject) signal
 ]
 
+{ #category : #signalling }
+DASTPrimitiveFailed class >> signalWithPrimitive: anInteger receiver: anObject errorCode: ec [
+
+	^ (self primitiveNumber: anInteger receiver: anObject errorCode: ec)
+		  signal
+]
+
+{ #category : #accessing }
+DASTPrimitiveFailed >> errorCode [
+
+	^ errorCode
+]
+
+{ #category : #accessing }
+DASTPrimitiveFailed >> errorCode: anObject [
+
+	errorCode := anObject
+]
+
+{ #category : #testing }
+DASTPrimitiveFailed >> isResumable [
+
+	^ true
+]
+
 { #category : #accessing }
 DASTPrimitiveFailed >> primitiveNumber: anInteger [ 
 	primitiveNumber := anInteger