diff --git a/DebuggableASTInterpreter/DASTInterpreter.class.st b/DebuggableASTInterpreter/DASTInterpreter.class.st index 3e73c77..9ebba02 100644 --- a/DebuggableASTInterpreter/DASTInterpreter.class.st +++ b/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 } diff --git a/DebuggableASTInterpreter/DASTInterpreterTests.class.st b/DebuggableASTInterpreter/DASTInterpreterTests.class.st index ee27ea3..c037f13 100644 --- a/DebuggableASTInterpreter/DASTInterpreterTests.class.st +++ b/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 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') diff --git a/DebuggableASTInterpreter/DASTMethodContext.class.st b/DebuggableASTInterpreter/DASTMethodContext.class.st index 08c4e64..fd5c935 100644 --- a/DebuggableASTInterpreter/DASTMethodContext.class.st +++ b/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; diff --git a/DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st b/DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st index c4dba67..9c8e460 100644 --- a/DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st +++ b/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 ] diff --git a/DebuggableASTInterpreter/DASTPrimitiveFailed.class.st b/DebuggableASTInterpreter/DASTPrimitiveFailed.class.st index c7ec151..38f177b 100644 --- a/DebuggableASTInterpreter/DASTPrimitiveFailed.class.st +++ b/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