diff --git a/DebuggableASTDebugger/BlockClosure.extension.st b/DebuggableASTDebugger/BlockClosure.extension.st new file mode 100644 index 0000000..325b3c2 --- /dev/null +++ b/DebuggableASTDebugger/BlockClosure.extension.st @@ -0,0 +1,10 @@ +Extension { #name : #BlockClosure } + +{ #category : #'*DebuggableASTDebugger' } +BlockClosure >> bcToDASTValue [ + + ^ DASTBlock new + initializeWith: self compiledBlock ast; + pharoOuterContext: self outerContext; + yourself +] diff --git a/DebuggableASTDebugger/Context.extension.st b/DebuggableASTDebugger/Context.extension.st new file mode 100644 index 0000000..2a81c7c --- /dev/null +++ b/DebuggableASTDebugger/Context.extension.st @@ -0,0 +1,14 @@ +Extension { #name : #Context } + +{ #category : #'*DebuggableASTDebugger' } +Context >> dastValueFor: anObject interpretedBy: aDASTInterpreter withClosureToBlockDictionary: closureToDASTBlock [ + + | value | + (closureToDASTBlock includesKey: anObject) ifTrue: [ + ^ closureToDASTBlock at: anObject ]. + value := anObject bcToDASTValue. + value isBlock ifTrue: [ + value outerContext: self. "aDASTInterpreter currentContext" + closureToDASTBlock at: anObject put: value ]. + ^ value +] diff --git a/DebuggableASTDebugger/DASTBlock.extension.st b/DebuggableASTDebugger/DASTBlock.extension.st new file mode 100644 index 0000000..3528636 --- /dev/null +++ b/DebuggableASTDebugger/DASTBlock.extension.st @@ -0,0 +1,7 @@ +Extension { #name : #DASTBlock } + +{ #category : #'*DebuggableASTDebugger' } +DASTBlock >> dastToBcValue [ + + ^ self closure +] diff --git a/DebuggableASTDebugger/DASTBlockContext.extension.st b/DebuggableASTDebugger/DASTBlockContext.extension.st new file mode 100644 index 0000000..653411a --- /dev/null +++ b/DebuggableASTDebugger/DASTBlockContext.extension.st @@ -0,0 +1,15 @@ +Extension { #name : #DASTBlockContext } + +{ #category : #'*DebuggableASTDebugger' } +DASTBlockContext >> tempNamed: aTempVarName [ + + ^ [ super tempNamed: aTempVarName ] + on: KeyNotFound + do: [ + [ + self sender + ifNotNil: [ self sender tempNamed: aTempVarName ] + ifNil: [ closure outerContext tempNamed: aTempVarName ] ] + on: KeyNotFound + do: [ closure outerContext tempNamed: aTempVarName ] ] +] diff --git a/DebuggableASTDebugger/DASTDebugger.class.st b/DebuggableASTDebugger/DASTDebugger.class.st new file mode 100644 index 0000000..e222924 --- /dev/null +++ b/DebuggableASTDebugger/DASTDebugger.class.st @@ -0,0 +1,195 @@ +Class { + #name : #DASTDebugger, + #superclass : #SpPresenter, + #traits : 'TDebugger', + #classTraits : 'TDebugger classTrait', + #instVars : [ + 'stack', + 'code', + 'interpreter', + 'toolBar', + 'simulatorSession', + 'switchButton' + ], + #category : #DebuggableASTDebugger +} + +{ #category : #'instance creation' } +DASTDebugger class >> debugSession: aDebugSession [ + + | dast | + dast := self basicNew. + dast simulatorSession: aDebugSession. + aDebugSession interruptedContext receiver class == DASTBreakpoint + ifTrue: [ + aDebugSession stepInto. + aDebugSession stepInto ]. + dast interpreter: + (DASTInterpreter startFromContext: aDebugSession interruptedContext). + dast initialize. + dast open +] + +{ #category : #accessing } +DASTDebugger class >> defaultDebuggerRank [ + + ^ 10 +] + +{ #category : #debugging } +DASTDebugger class >> handlesDebugSession: aDebugSession [ + + ^ aDebugSession exception class = DASTException or: [ + aDebugSession interruptedContext receiver class = DASTBreakpoint ] +] + +{ #category : #initialization } +DASTDebugger >> buildToolbar [ + + ^ self newToolbar + addItem: (SpToolbarButtonPresenter new + label: 'Proceed'; + icon: (self iconNamed: #glamorousSpawn); + action: [ self proceed ]; + yourself); + addItem: (SpToolbarButtonPresenter new + label: 'Step'; + icon: (self iconNamed: #down); + action: [ self stepInterpreter ]; + yourself); + addItem: (SpToolbarButtonPresenter new + label: 'Step over'; + icon: (self iconNamed: #forward); + action: [ self stepOver ]; + yourself); + addItem: (SpToolbarButtonPresenter new + label: 'Step through'; + icon: (self iconNamed: #glamorousThrough); + action: [ self stepThrough ]; + yourself); + addItem: (SpToolbarButtonPresenter new + label: 'Restart'; + icon: (self iconNamed: #glamorousRestart); + action: [ self restart ]; + yourself); + yourself +] + +{ #category : #accessing } +DASTDebugger >> clear [ + simulatorSession terminate +] + +{ #category : #layout } +DASTDebugger >> defaultLayout [ + + ^ SpBoxLayout newVertical + add: (SpBoxLayout newTopToBottom + add: switchButton + expand: false + fill: false + padding: 5; + add: stack; + yourself); + add: toolBar expand: false; + add: code; + yourself +] + +{ #category : #initialization } +DASTDebugger >> initializePresenters [ + + code := self newCode. + stack := self newList + transmitDo: [ :ctx | self updateCodeFromContext: ctx ]; + yourself. + toolBar := self buildToolbar. + switchButton := self newButton action: [ self switchToOtherDebugger ]. + self updateStack +] + +{ #category : #accessing } +DASTDebugger >> interpreter: aDASTInterpreter [ + + interpreter := aDASTInterpreter +] + +{ #category : #menu } +DASTDebugger >> proceed [ + + interpreter evaluate. + self updateStack +] + +{ #category : #menu } +DASTDebugger >> restart [ + + interpreter restart: stack selectedItem. + self updateStack +] + +{ #category : #accessing } +DASTDebugger >> simulatorSession: anObject [ + + simulatorSession := anObject +] + +{ #category : #'as yet unclassified' } +DASTDebugger >> stepInterpreter [ + + + interpreter stepInto. + self updateStack +] + +{ #category : #'debug - stepping' } +DASTDebugger >> stepOver [ + + interpreter stepOver. + self updateStack +] + +{ #category : #actions } +DASTDebugger >> stepThrough [ + + interpreter stepThrough. + self updateStack +] + +{ #category : #initialization } +DASTDebugger >> switchToOtherDebugger [ + + | context process | + context := interpreter currentContext asContext. + process := Process + forContext: context + priority: Processor userInterruptPriority. + (OupsDebugRequest newForContext: context) + label: context compiledCode printString; + process: process; + submit. + self clear. + self window close +] + +{ #category : #'presenter - code' } +DASTDebugger >> updateCodeFromContext: aDASTContext [ + + aDASTContext ifNil: [ ^ nil ]. + code text: aDASTContext sourceCode. + code beForContext: aDASTContext. + code removeAllTextSegmentDecorations. + + code addTextSegmentDecoration: (SpTextPresenterDecorator forHighlight + interval: (aDASTContext currentNode start to: aDASTContext currentNode stop + 1); + yourself). + +] + +{ #category : #'as yet unclassified' } +DASTDebugger >> updateStack [ + + stack + items: interpreter contextsStack; + selectFirst +] diff --git a/DebuggableASTDebugger/Object.extension.st b/DebuggableASTDebugger/Object.extension.st new file mode 100644 index 0000000..1888a29 --- /dev/null +++ b/DebuggableASTDebugger/Object.extension.st @@ -0,0 +1,13 @@ +Extension { #name : #Object } + +{ #category : #'*DebuggableASTDebugger' } +Object >> bcToDASTValue [ + + ^ self +] + +{ #category : #'*DebuggableASTDebugger' } +Object >> dastToBcValue [ + + ^ self +] diff --git a/DebuggableASTDebuggerExperiment/ClyAddDASTBreakpointCommand.class.st b/DebuggableASTDebuggerExperiment/ClyAddDASTBreakpointCommand.class.st new file mode 100644 index 0000000..3c02bf9 --- /dev/null +++ b/DebuggableASTDebuggerExperiment/ClyAddDASTBreakpointCommand.class.st @@ -0,0 +1,36 @@ +Class { + #name : #ClyAddDASTBreakpointCommand, + #superclass : #ClyAddStaticBreakpointCommand, + #category : #DebuggableASTDebuggerExperiment +} + +{ #category : #testing } +ClyAddDASTBreakpointCommand class >> canBeExecutedInContext: aBrowserContext [ + + ^ (super canBeExecutedInContext: aBrowserContext) and: [ + aBrowserContext isSelectedItemHasBreakpoint not ] +] + +{ #category : #activation } +ClyAddDASTBreakpointCommand class >> contextMenuOrder [ + + ^1 +] + +{ #category : #testing } +ClyAddDASTBreakpointCommand class >> isAbstract [ + ^self = ClyAddBreakpointCommand +] + +{ #category : #accessing } +ClyAddDASTBreakpointCommand >> defaultMenuItemName [ + ^'DAST breakpoint' +] + +{ #category : #execution } +ClyAddDASTBreakpointCommand >> execute [ + + | breakpoint | + breakpoint := DASTBreakpoint new node: sourceNode. + breakpoint install +] diff --git a/DebuggableASTDebuggerExperiment/DASTBreakpoint.class.st b/DebuggableASTDebuggerExperiment/DASTBreakpoint.class.st new file mode 100644 index 0000000..8c6bf64 --- /dev/null +++ b/DebuggableASTDebuggerExperiment/DASTBreakpoint.class.st @@ -0,0 +1,12 @@ +" +1/0. +bp := +DASTBreakpoint new node: (StDebuggerObjectForTests>>#instVar) ast. +bp install. +StDebuggerObjectForTests new instVar +" +Class { + #name : #DASTBreakpoint, + #superclass : #Breakpoint, + #category : #DebuggableASTDebuggerExperiment +} diff --git a/DebuggableASTDebuggerExperiment/StDebugger.extension.st b/DebuggableASTDebuggerExperiment/StDebugger.extension.st new file mode 100644 index 0000000..6747fd7 --- /dev/null +++ b/DebuggableASTDebuggerExperiment/StDebugger.extension.st @@ -0,0 +1,20 @@ +Extension { #name : #StDebugger } + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebugger class >> buildDASTCommandsGroupWith: stDebuggerInstance forRoot: aRootGroup [ + + + | configGroup dastConfigGroup | + configGroup := aRootGroup + / StDebuggerConfigurationCommandTreeBuilder groupName. + dastConfigGroup := StDebuggerConfigurationCommandTreeBuilder new + dastConfigurationCommandsGroup. + configGroup register: dastConfigGroup +] + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebugger >> programmaticallyClose [ + + programmaticallyClosed := true. + self withWindowDo: #close +] diff --git a/DebuggableASTDebuggerExperiment/StDebuggerConfigurationCommandTreeBuilder.extension.st b/DebuggableASTDebuggerExperiment/StDebuggerConfigurationCommandTreeBuilder.extension.st new file mode 100644 index 0000000..b6ffeac --- /dev/null +++ b/DebuggableASTDebuggerExperiment/StDebuggerConfigurationCommandTreeBuilder.extension.st @@ -0,0 +1,33 @@ +Extension { #name : #StDebuggerConfigurationCommandTreeBuilder } + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebuggerConfigurationCommandTreeBuilder >> dastConfigurationCommandsClasses [ + + ^ { StSwitchToDASTCommand } +] + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebuggerConfigurationCommandTreeBuilder >> dastConfigurationCommandsGroup [ + + | group | + group := (CmCommandGroup named: self dastConfigurationGroupName) + asSpecGroup. + group beDisplayedAsSubMenu. + group description: self dastConfigurationGroupDescription. + self dastConfigurationCommandsClasses do: [ :c | + group register: + (self buildSpecCommand: c forContext: stDebuggerInstance) ]. + ^ group +] + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebuggerConfigurationCommandTreeBuilder >> dastConfigurationGroupDescription [ + + ^ 'Configuration commands to perform actions with DAST interpreter' +] + +{ #category : #'*DebuggableASTDebuggerExperiment' } +StDebuggerConfigurationCommandTreeBuilder >> dastConfigurationGroupName [ + + ^ 'DAST configuration' +] diff --git a/DebuggableASTDebuggerExperiment/StSwitchToDASTCommand.class.st b/DebuggableASTDebuggerExperiment/StSwitchToDASTCommand.class.st new file mode 100644 index 0000000..d815d33 --- /dev/null +++ b/DebuggableASTDebuggerExperiment/StSwitchToDASTCommand.class.st @@ -0,0 +1,29 @@ +Class { + #name : #StSwitchToDASTCommand, + #superclass : #StDebuggerCommand, + #category : #DebuggableASTDebuggerExperiment +} + +{ #category : #initialization } +StSwitchToDASTCommand class >> defaultIconName [ + + ^ #halt +] + +{ #category : #initialization } +StSwitchToDASTCommand class >> defaultShortcut [ + + ^ $d meta , $s meta +] + +{ #category : #executing } +StSwitchToDASTCommand >> execute [ + + | session | + session := self context session. + self context programmaticallyClose. + (OupsDebugRequest newForContext: context) + label: session interruptedContext compiledCode printString; + exception: (DASTException fromSignallerContext: session interruptedContext); + "DASTDebugger debugSession: session"submit +] diff --git a/DebuggableASTDebuggerExperiment/package.st b/DebuggableASTDebuggerExperiment/package.st new file mode 100644 index 0000000..7184993 --- /dev/null +++ b/DebuggableASTDebuggerExperiment/package.st @@ -0,0 +1 @@ +Package { #name : #DebuggableASTDebuggerExperiment } diff --git a/DebuggableASTInterpreter/Context.extension.st b/DebuggableASTInterpreter/Context.extension.st new file mode 100644 index 0000000..e504154 --- /dev/null +++ b/DebuggableASTInterpreter/Context.extension.st @@ -0,0 +1,105 @@ +Extension { #name : #Context } + +{ #category : #'*DebuggableASTInterpreter' } +Context >> asDASTContextInterpretedBy: aDASTInterpreter [ + + | dastCtx bindings aimedNode currentNode dastSender closureToDASTBlock tempNames | + closureToDASTBlock := Dictionary new. + dastCtx := self compiledCode isDoIt + ifTrue: [ + DASTContext + newNoMethodContextWithProgram: self compiledCode ast + temps: { } + evaluator: aDASTInterpreter evaluator ] + ifFalse: [ + DASTContext + newWithSender: + (dastSender := sender asDASTContextInterpretedBy: + aDASTInterpreter) + receiver: (closureOrNil + ifNil: [ + self + dastValueFor: receiver + interpretedBy: aDASTInterpreter + withClosureToBlockDictionary: closureToDASTBlock ] + ifNotNil: [ + | dastBlock | + dastBlock := self + dastValueFor: closureOrNil + interpretedBy: aDASTInterpreter + withClosureToBlockDictionary: + closureToDASTBlock. + (dastBlock outerContext isNil or: [ + dastBlock outerContext isDead not ]) + ifTrue: [ "DASTBlock new + nodeAST: closureOrNil compiledBlock ast; + outerContext: (dastSender isRoot + ifFalse: [ dastSender ] + ifTrue: [" + self flag: + 'Maybe it is weird that the outer context is a context but I haven''t found a better solution yet.'. + dastBlock + outerContext: self outerContext; + "]); + yourself + dastBlock + outerContext: + (self outerContext asDASTContextInterpretedBy: + aDASTInterpreter); + yourself ]" + yourself ] + ifFalse: [ dastBlock ] ]) + messageNode: (dastSender isRoot + ifTrue: [ + RBMessageNode + receiver: (RBLiteralValueNode value: nil) + selector: #value ] + ifFalse: [ sender sourceNodeExecuted ]) + evaluator: aDASTInterpreter evaluator ]. + DASTContext bcToDASTContextMap at: self put: dastCtx. + bindings := Dictionary new. + "need to find right set of temp names" + tempNames := (self isBlockContext and: [ + (DASTContext bcToDASTContextMap keys + detect: [ :each | each == self outerContext ] + ifNone: [ nil ]) isNotNil ]) + ifTrue: [ + self tempNames difference: self outerContext tempNames ] + ifFalse: [ self tempNames ]. + tempNames do: [ :tempName | + | contextTemp dastTemp | + contextTemp := self tempNamed: tempName. + dastTemp := self + dastValueFor: contextTemp + interpretedBy: aDASTInterpreter + withClosureToBlockDictionary: closureToDASTBlock. + bindings at: tempName put: dastTemp ]. + dastCtx isDead: self isDead. + dastCtx temps: bindings associations. + + self pc + ifNil: [ + aimedNode := dastCtx nodes first. + dastCtx isDead: true ] + ifNotNil: [ aimedNode := self compiledCode sourceNodeForPC: self pc ]. + [ aimedNode == dastCtx nodes top ] whileFalse: [ + dastCtx executedNodes push: (currentNode := dastCtx nodes pop) ]. + dastCtx currentNode: currentNode. + (Interval from: self numTemps + 1 to: self stackPtr) do: [ :each | + dastCtx stack push: (self + dastValueFor: (self at: each) + interpretedBy: aDASTInterpreter + withClosureToBlockDictionary: closureToDASTBlock) ]. + closureToDASTBlock do: [ :each | + each outerContext: (DASTContext bcToDASTContextMap + at: self outerContext + ifAbsent: [ self outerContext ]) ]. + ^ dastCtx +] + +{ #category : #'*DebuggableASTInterpreter' } +Context >> nodeForCurrentPC [ + + ^ self method ast sourceNodeForPC: pc + +] diff --git a/DebuggableASTInterpreter/DASTBlock.class.st b/DebuggableASTInterpreter/DASTBlock.class.st index 358c19a..c909baf 100644 --- a/DebuggableASTInterpreter/DASTBlock.class.st +++ b/DebuggableASTInterpreter/DASTBlock.class.st @@ -2,7 +2,8 @@ Class { #name : #DASTBlock, #superclass : #DASTClosure, #instVars : [ - 'interval' + 'interval', + 'pharoOuterContext' ], #category : #'DebuggableASTInterpreter-Closures' } @@ -29,6 +30,27 @@ DASTBlock >> bodyOffset [ ^ self outerContext methodOrBlock bodyOffset ] +{ #category : #accessing } +DASTBlock >> closure [ + + ^ FullBlockClosure new + compiledBlock: self nodeAST ir compiledMethod; + receiver: self outerContext receiver; + numArgs: self nodeAST numArgs; + outerContext: self pharoOuterContext "closure ifNil: [ ""self nodeAST evaluate" + "closure := Smalltalk compiler + source: self sourceCode; + context: self outerContext; + receiver: self outerContext receiver; + evaluate ]" +] + +{ #category : #accessing } +DASTBlock >> compiledCode [ + + ^ self nodeAST ir compiledMethod +] + { #category : #accessing } DASTBlock >> ensure: aBlock [ "Evaluate a termination block after evaluating the receiver, regardless of @@ -116,7 +138,19 @@ DASTBlock >> outerContext [ { #category : #accessing } DASTBlock >> outerContext: aDASTContext [ outerContext := aDASTContext. - self initializeInterval + "self initializeInterval" +] + +{ #category : #accessing } +DASTBlock >> pharoOuterContext [ + + ^ pharoOuterContext +] + +{ #category : #accessing } +DASTBlock >> pharoOuterContext: anObject [ + + pharoOuterContext := anObject ] { #category : #accessing } diff --git a/DebuggableASTInterpreter/DASTBlockContext.class.st b/DebuggableASTInterpreter/DASTBlockContext.class.st index 8c44987..090ffa7 100644 --- a/DebuggableASTInterpreter/DASTBlockContext.class.st +++ b/DebuggableASTInterpreter/DASTBlockContext.class.st @@ -15,9 +15,16 @@ DASTBlockContext >> allInstVars [ { #category : #'accessing - private' } DASTBlockContext >> allTemps [ - ^ self variablesDict associations , - closure outerContext allTemps , - sender allTemps + + self flag: 'I really think that this statement duplicates temps'. + ^ self variablesDict associations ", closure outerContext allTemps" + , sender allTemps +] + +{ #category : #testing } +DASTBlockContext >> belongsToDoIt [ + self flag: 'wrong imoplementation, to fix'. + ^false ] { #category : #initialization } @@ -49,7 +56,7 @@ DASTBlockContext >> initializeContext [ ifFalse: [ self getClassForLookup ]. " visitor := DASTPostOrderTreeVisitor new. - receiver body acceptVisitor: visitor. + receiver "compiledBlock ast" body acceptVisitor: visitor. nodes := visitor stack. currentNode := nodes top. self methodOrBlock: receiver; @@ -57,6 +64,12 @@ DASTBlockContext >> initializeContext [ ] +{ #category : #helpers } +DASTBlockContext >> ir [ + + ^ self methodOrBlock nodeAST ir +] + { #category : #initialization } DASTBlockContext >> isBlockContext [ ^ true diff --git a/DebuggableASTInterpreter/DASTClosure.class.st b/DebuggableASTInterpreter/DASTClosure.class.st index bd9e263..223f59d 100644 --- a/DebuggableASTInterpreter/DASTClosure.class.st +++ b/DebuggableASTInterpreter/DASTClosure.class.st @@ -34,6 +34,18 @@ DASTClosure >> body [ ^ nodeAST body ] +{ #category : #accessing } +DASTClosure >> closure [ + + ^ nil +] + +{ #category : #accessing } +DASTClosure >> compiledCode [ + + self subclassResponsibility +] + { #category : #initialization } DASTClosure >> initializeWith: aRBNode [ @@ -76,9 +88,7 @@ DASTClosure >> nodeAST: aRBNode [ sourceCode := aRBNode sourceCode. nodeAST := aRBNode. - numArgs := nodeAST arguments size. - - nodeAST doSemanticAnalysis + numArgs := nodeAST arguments size ] { #category : #accessing } diff --git a/DebuggableASTInterpreter/DASTContext.class.st b/DebuggableASTInterpreter/DASTContext.class.st index fda8aa6..38aff3c 100644 --- a/DebuggableASTInterpreter/DASTContext.class.st +++ b/DebuggableASTInterpreter/DASTContext.class.st @@ -23,33 +23,44 @@ Class { 'isDead' ], #classVars : [ + 'BcToDASTContextMap', 'valueToBlockMessages' ], #category : #'DebuggableASTInterpreter-Contexts' } +{ #category : #'as yet unclassified' } +DASTContext class >> bcToDASTContextMap [ + + ^ BcToDASTContextMap ifNil: [ BcToDASTContextMap := WeakIdentityKeyDictionary new ] +] + { #category : #instantiation } DASTContext class >> newNoMethodContextWithProgram: aRBNode temps: aCollection evaluator: anEvaluator [ "special context for the first call" + | nodes rootContext noMethod | - nodes := DASTPostOrderTreeVisitor new flattenedNodesFrom: aRBNode. - - rootContext := DASTContextRootSmalltalk new - evaluator: anEvaluator; - yourself. - - noMethod := (DASTMethod new initializeWith: nodes last methodNode evaluator: anEvaluator). + + rootContext := DASTContextRootSmalltalk new + evaluator: anEvaluator; + currentNode: (RBMessageNode + receiver: (RBLiteralValueNode value: nil) + selector: #value) yourself. + + noMethod := DASTNoMethod new + initializeWith: nodes last methodNode + evaluator: anEvaluator. " Set the first method (noMethod) context evaluation. The receiver is nil " ^ DASTMethodContext new - receiver: anEvaluator nilObject; - parent: rootContext; - methodOrBlock: noMethod; - nodes: nodes; - sender: rootContext; - temps: aCollection; - evaluator: anEvaluator; - yourself. + receiver: anEvaluator nilObject; + parent: rootContext; + methodOrBlock: noMethod; + nodes: nodes; + sender: rootContext; + temps: aCollection; + evaluator: anEvaluator; + yourself ] { #category : #instantiation } @@ -95,6 +106,32 @@ DASTContext >> allTemps [ self subclassResponsibility ] +{ #category : #accessing } +DASTContext >> arguments [ + + ^ (self methodOrBlock nodeAST arguments collect: [ :each | each name ]) + collect: [ :each | (self findLocalVariable: each) value ] +] + +{ #category : #converting } +DASTContext >> asContext [ + + | newContext nextNode nextPC nextNodes | + newContext := self privAsContext. + nextNodes := self nodes copy. + + "We need to change pc" + nextPC := nil. + [ nextPC ] whileNil: [ + nextNode := nextNodes pop. + nextPC := self methodOrBlock nodeAST firstPcForNode: nextNode ]. + newContext pc: nextPC. + + "We need to rebuild the stack" + self privCopyStackInContext: newContext. + ^ newContext +] + { #category : #'API-lookup' } DASTContext >> assignVariable: name value: value [ "Temporary variables assignment" @@ -127,6 +164,17 @@ DASTContext >> at: aByteSymbol put: anObject [ ] +{ #category : #'as yet unclassified' } +DASTContext >> bcValueForAnObject: anObject forContext: newContext [ + + | bcValue | + anObject isBlock ifTrue: [ + anObject pharoOuterContext ifNil: [ + anObject pharoOuterContext: newContext ] ]. + bcValue := anObject dastToBcValue. + ^ bcValue +] + { #category : #testing } DASTContext >> canExecute [ ^ self nodes isNotEmpty and: [ self unhandledException isNil ] @@ -426,16 +474,23 @@ DASTContext >> hasSender: context [ { #category : #initialization } DASTContext >> initialize [ + super initialize. stack := DASTStack new. executedNodes := DASTStack new. nodes := DASTStack new. currentNode := nil. - variablesDict := Dictionary new. + variablesDict := OrderedDictionary new. tempVarsNamesIndexes := Dictionary new. tempVarIndex := 0 ] +{ #category : #helpers } +DASTContext >> ir [ + + self subclassResponsibility +] + { #category : #testing } DASTContext >> isBlockContext [ @@ -587,17 +642,72 @@ DASTContext >> parent: aDASTContext [ { #category : #accessing } DASTContext >> printOn: aStream [ - "aStream + aStream cr; nextPutAll: (receiver ifNotNil: [ receiver asString ] ifNil: [ 'nil' ]); nextPutAll: ' <- '; - nextPutAll: (closure ifNotNil: [ closure selector asString ] ifNil: ['nil'])." - + nextPutAll: (closure ifNotNil: [ closure selector asString ] ifNil: ['nil']). + " aStream - nextPutAll: 'DAST Context standard' + nextPutAll: 'DAST Context standard'" ] +{ #category : #converting } +DASTContext >> privAsContext [ + + ^ (Context newForMethod: self method) + setSender: self sender asContext + receiver: self receiver + method: self methodOrBlock compiledCode + closure: self methodOrBlock closure + startpc: self methodOrBlock compiledCode initialPC +] + +{ #category : #converting } +DASTContext >> privCopyStackInContext: newContext [ + + newContext stackp: 0. + (self ir tempMap associations sorted: [ :assoc1 :assoc2 | + assoc1 value <= assoc2 value ]) do: [ :each | + | value | + [ + value := (self allTemps detect: [ :tempAssoc | + tempAssoc key == each key ]) value ] + on: NotFound + do: [ "newContext sender or newContext outerContext" + [ value := newContext sender tempNamed: each key ] + on: Error + do: [ + | scope tempVector index | + scope := self methodOrBlock nodeAST scope. + self + assert: scope tempVector isEmpty not + description: 'Temp named ' , each key , ' is missing'. + tempVector := scope tempVector. + value := Array new: tempVector size. + index := 1. + tempVector keysDo: [ :key | + value + at: index + put: + (self + bcValueForAnObject: (self tempNamed: key) + forContext: newContext). + index := index + 1 ] ] ]. + newContext push: + (self bcValueForAnObject: value forContext: newContext) ]. + "(self variablesDict associations collect: [ :each | + | value | + value := each value. + value isBlock + ifFalse: [ value ] + ifTrue: [ value nodeAST evaluate ] ]) ," + self stack do: [ :each | + newContext push: + (self bcValueForAnObject: each forContext: newContext) ] +] + { #category : #accessing } DASTContext >> receiver [ ^ receiver @@ -718,6 +828,11 @@ DASTContext >> tempAt: anIndex [ ^ self variablesDict at: (self variablesDict keys at: anIndex) ] +{ #category : #accessing } +DASTContext >> temps: aCollection [ + aCollection do: [ :assoc | self at: assoc key put: assoc value ] +] + { #category : #'private-exceptions' } DASTContext >> terminate [ "Make myself unresumable." diff --git a/DebuggableASTInterpreter/DASTContextRootSmalltalk.class.st b/DebuggableASTInterpreter/DASTContextRootSmalltalk.class.st index 8112060..1d41386 100644 --- a/DebuggableASTInterpreter/DASTContextRootSmalltalk.class.st +++ b/DebuggableASTInterpreter/DASTContextRootSmalltalk.class.st @@ -18,6 +18,18 @@ DASTContextRootSmalltalk >> allTemps [ ^ #() ] +{ #category : #accessing } +DASTContextRootSmalltalk >> arguments [ + + ^ { } asOrderedCollection +] + +{ #category : #converting } +DASTContextRootSmalltalk >> asContext [ + + ^ [ Processor terminateRealActive] asContext +] + { #category : #accessing } DASTContextRootSmalltalk >> assignVariable: name value: value [ (self findVariable: name) @@ -25,6 +37,12 @@ DASTContextRootSmalltalk >> assignVariable: name value: value [ ^ false ] +{ #category : #testing } +DASTContextRootSmalltalk >> belongsToDoIt [ + + ^ false +] + { #category : #'API-lookup' } DASTContextRootSmalltalk >> findLocalVariable: aName [ ^ nil @@ -63,6 +81,14 @@ DASTContextRootSmalltalk >> methodClass [ ^ nil ] +{ #category : #converting } +DASTContextRootSmalltalk >> privCopyStackInContext: newContext [ + + "nothing to copy when self isRoot" + + +] + { #category : #'gt-extension' } DASTContextRootSmalltalk >> sourceCode [ ^ '' diff --git a/DebuggableASTInterpreter/DASTContextSwitchTests.class.st b/DebuggableASTInterpreter/DASTContextSwitchTests.class.st new file mode 100644 index 0000000..cedc63b --- /dev/null +++ b/DebuggableASTInterpreter/DASTContextSwitchTests.class.st @@ -0,0 +1,932 @@ +Class { + #name : #DASTContextSwitchTests, + #superclass : #TestCase, + #instVars : [ + 'context', + 'dastInterpreter', + 'dastContext' + ], + #category : #'DebuggableASTInterpreter-Tests' +} + +{ #category : #'tests - helper' } +DASTContextSwitchTests >> assertFullBlock: fullBlock equalsDASTBlock: dastBlock [ + + | closure | + self assert: fullBlock isClosure. + self assert: dastBlock isBlock. + closure := dastBlock closure. + ^ self + assert: fullBlock compiledBlock + identicalTo: closure compiledBlock; + assert: fullBlock outerContext identicalTo: closure outerContext; + assert: fullBlock receiver identicalTo: closure receiver +] + +{ #category : #'tests - helper' } +DASTContextSwitchTests >> bcStepUntil: aBlock [ + + aBlock whileTrue: [ context := context step ] +] + +{ #category : #'as yet unclassified' } +DASTContextSwitchTests >> contextOnMethodWithTempVector [ + + context := [ + | debuggerObjectForTest block a b | + debuggerObjectForTest := StDebuggerObjectForTests new. + a := 0. + block := [ + | c | + debuggerObjectForTest methodWithTempsAssignments. + 1 = 2 ifTrue: [ block value ]. + a := a + 1. + b := 0. + c := 0. + [ + a := a + 2. + c := c + 4. + b := b + 3 ] value ]. + block value + b + a ] asContext +] + +{ #category : #'tests - helper' } +DASTContextSwitchTests >> dastStepUntil: aBlock [ + + aBlock whileTrue: [ dastInterpreter stepInto ]. + dastContext := dastInterpreter currentContext +] + +{ #category : #'tests - helper' } +DASTContextSwitchTests >> interpreterOnMethodWithTempVector [ + + dastInterpreter initializeWithProgram: + (RBParser parseExpression: '| debuggerObjectForTest block a b | + debuggerObjectForTest := StDebuggerObjectForTests new. + a := 0. + block := [ | c | debuggerObjectForTest methodWithTempsAssignments. 1=2 ifTrue: [ block value ]. a := a + 1. b:=0. c:=0 . [ a:= a + 2. c:=c+4. b:=b+3 ] value ]. + ^ block value + b + a'). + + dastContext := dastInterpreter currentContext +] + +{ #category : #running } +DASTContextSwitchTests >> setUp [ + + | debuggerObjectForTest | + super setUp. + "context initialization" + debuggerObjectForTest := StDebuggerObjectForTests new. + context := [ debuggerObjectForTest methodWithTempsAssignments ] + asContext. + 2 timesRepeat: [ context := context step ]. + + "DASTInterpreter initialization (which initializes DAST contexts)" + dastInterpreter := DASTInterpreter new. + dastInterpreter initializeWithProgram: + (RBParser parseExpression: '| debuggerObjectForTest block | + debuggerObjectForTest := StDebuggerObjectForTests new. + block := [ debuggerObjectForTest methodWithTempsAssignments ]. + block value'). + "We step until we step into StDebuggerObjectForTests>>#methodWithTempsAssignments" + 8 timesRepeat: [ dastInterpreter stepOver ]. + 5 timesRepeat: [ dastInterpreter stepInto ]. + dastContext := dastInterpreter currentContext +] + +{ #category : #running } +DASTContextSwitchTests >> tearDown [ + "context terminate." + + super tearDown. + context := nil. + dastContext := nil. + dastInterpreter := nil +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchBottomContextMapsToRootAndTerminatesProcess [ + + | process | + 4 timesRepeat: [ dastInterpreter stepInto ]. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + dastContext := dastContext sender. + context := context sender ]. + + self assert: context sender isNil. + + process := Process + forContext: context + priority: Processor userInterruptPriority. + + self deny: process isTerminated. + self shouldnt: [ process resume ] raise: BlockCannotReturn. + self assert: process isTerminated +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchCurrentPcIsFirstPcOfTopNodeOnStack [ + + | node | + 4 timesRepeat: [ dastInterpreter stepInto ]. + + context := dastContext asContext. + + node := dastContext nodes top. + + self + assert: context pc + identicalTo: + (dastContext methodOrBlock nodeAST firstPcForNode: node) +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchCurrentPcIsFirstPcOfTopNodeOnStackRecursively [ + + | node | + 4 timesRepeat: [ dastInterpreter stepInto ]. + node := dastContext nodes top. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + node := dastContext nodes top. + + self + assert: context pc + identicalTo: + (dastContext methodOrBlock nodeAST firstPcForNode: node). + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsBindings [ + "we step after the node `b := 2 ` of StDebuggerObjectForTests>>#methodWithTempsAssignments has been executed" + + 4 timesRepeat: [ dastInterpreter stepInto ]. + self assert: (dastContext findLocalVariable: #a) value equals: 40. + self assert: (dastContext findLocalVariable: #b) value equals: 2. + + context := dastContext asContext. + + self + assert: ((context lookupTempVar: #a) readInContext: context) + equals: 40. + self + assert: ((context lookupTempVar: #b) readInContext: context) + equals: 2 +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsBindingsRecursively [ + "we step after the node `b := 2 ` of StDebuggerObjectForTests>>#methodWithTempsAssignments has been executed" + + "The test fails because I don't manage to get a compiled block (and thus a block closure) that contains the bindings of variables from the outer context. I suppose there are something to do with the compiler. I tried to compile the block in the DAST outer context but it doesn't work (DNU). I don't know if defining these messages would solve the problem" + + | tempNames dastTemp | + 4 timesRepeat: [ dastInterpreter stepInto ]. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + tempNames := dastContext allTemps collect: [ :each | each key ]. + tempNames do: [ :temp | + dastTemp := (dastContext findLocalVariable: temp) value. + dastTemp isBlock + ifFalse: [ + self + assert: ((context lookupTempVar: temp) readInContext: context) + identicalTo: dastTemp ] + ifTrue: [ + | contextTemp | + contextTemp := (context lookupTempVar: temp) readInContext: + context. + self assertFullBlock: contextTemp equalsDASTBlock: dastTemp ] ]. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsReceiver [ + + 4 timesRepeat: [ dastInterpreter stepInto ]. + + context := dastContext asContext. + self assert: context receiver identicalTo: dastContext receiver +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsReceiversRecursively [ + + 4 timesRepeat: [ dastInterpreter stepInto ]. + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + self assert: context receiver identicalTo: dastContext receiver. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsValueStack [ + + | stack | + 4 timesRepeat: [ dastInterpreter stepInto ]. + stack := dastContext stack. + + context := dastContext asContext. + + self + assert: context stackPtr + equals: dastContext allTemps size + stack size. + self assert: dastContext allTemps size equals: context numTemps. + (Interval from: 1 to: stack size) do: [ :index | + self + assert: (dastContext stack at: index) + identicalTo: (context at: context numTemps + index) ]. + (Interval from: 1 to: dastContext allTemps size) do: [ :index | + self + assert: (context at: index) + identicalTo: (dastContext allTemps at: index) value ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchKeepsValueStackRecursively [ + + | stack dastElement contextElement | + "The test fails because a block context relies on its variable dict to build the new context's stack, instead of allTemps. Maybe (Surely) that my approach of using allTemps is wrong but this block context needs at least a vector of temps from allTemps." + 4 timesRepeat: [ dastInterpreter stepInto ]. + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + stack := dastContext stack. + + self + assert: context stackPtr + equals: dastContext ir tempMap size + stack size. + self assert: dastContext ir tempMap size equals: context numTemps. + (Interval from: 1 to: stack size) do: [ :index | + dastElement := dastContext stack at: index. + contextElement := context at: context numTemps + index. + dastElement isBlock + ifFalse: [ self assert: contextElement identicalTo: dastElement ] + ifTrue: [ + self assertFullBlock: contextElement equalsDASTBlock: dastElement ] ]. + (Interval from: 1 to: dastContext ir tempMap size) do: [ :index | + contextElement := context at: index. + dastElement := (dastContext tempNamed: + (dastContext allTemps at: index) key) value. + dastElement isBlock + ifFalse: [ self assert: contextElement identicalTo: dastElement ] + ifTrue: [ + self assertFullBlock: contextElement equalsDASTBlock: dastElement ] ]. + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchProcessResume [ + + | process | + context := dastContext asContext. + + process := Process + forContext: context + priority: Processor userInterruptPriority. + + [ dastContext isRoot ] whileFalse: [ + context := context sender. + dastContext := dastContext sender ]. + + process completeTo: context. + + self assert: process suspendedContext top equals: 42. + + self deny: process isTerminated. + + self shouldnt: [ process resume ] raise: BlockCannotReturn. + + self assert: process isTerminated +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchReceiverRemainsUnchanged [ + + | instVars oldInstVarValues newInstVarValues | + 4 timesRepeat: [ dastInterpreter stepInto ]. + + instVars := dastContext receiver class allInstVarNames. + oldInstVarValues := instVars collect: [ :inst | + dastContext receiver instVarNamed: inst ]. + + context := dastContext asContext. + + newInstVarValues := instVars collect: [ :inst | + context receiver instVarNamed: inst ]. + + oldInstVarValues withIndexDo: [ :each :index | + self assert: each identicalTo: (newInstVarValues at: index) ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchStepIsCorrect [ + + | pc node process | + 4 timesRepeat: [ dastInterpreter stepInto ]. + + node := dastContext nodes top. + context := dastContext asContext. + pc := dastContext methodOrBlock nodeAST firstPcForNode: node. + + process := Process + forContext: context + priority: Processor userInterruptPriority. + + self assert: process suspendedContext pc identicalTo: pc. + self deny: context isDead. + self assert: process suspendedContext identicalTo: context. + + "one step to evaluate a (40), one step to evaluate b (2) and one step to compute the sum" + process + step; + step; + step. + + self assert: process suspendedContext top equals: 42. + self assert: (process suspendedContext compiledCode sourceNodeForPC: + process suspendedContext pc) isReturn. + self deny: process suspendedContext isDead. + self assert: process suspendedContext identicalTo: context +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchTempVectorBindings [ + + | dastTemp | + self + interpreterOnMethodWithTempVector; + dastStepUntil: [ + (dastInterpreter currentNode isMessage and: [ + dastInterpreter currentNode selector = #+ and: [ + dastInterpreter currentNode arguments last isLiteralNode and: [ + dastInterpreter currentNode arguments last value = 3 ] ] ]) + not ]. + dastContext := dastInterpreter currentContext. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + | tempNames | + tempNames := dastContext allTemps collect: [ :each | each key ]. + tempNames do: [ :temp | + dastTemp := (dastContext findLocalVariable: temp) value. + dastTemp isBlock + ifFalse: [ + self + assert: ((context lookupTempVar: temp) readInContext: context) + identicalTo: dastTemp ] + ifTrue: [ + | contextTemp | + contextTemp := (context lookupTempVar: temp) readInContext: + context. + self assertFullBlock: contextTemp equalsDASTBlock: dastTemp ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchTempVectorCreation [ + + | astScope temp dastTemp vectorSize | + self + interpreterOnMethodWithTempVector; + dastStepUntil: [ + (dastInterpreter currentNode isMessage and: [ + dastInterpreter currentNode selector = #+ and: [ + dastInterpreter currentNode arguments last isLiteralNode and: [ + dastInterpreter currentNode arguments last value = 3 ] ] ]) + not ]. + dastContext := dastInterpreter currentContext. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ "ir := dastContext ir." + astScope := dastContext methodOrBlock nodeAST scope. + astScope tempVector ifNotEmpty: [ + temp := context tempNamed: astScope tempVectorName. + self assert: temp isArray. + vectorSize := 0. + astScope tempVector keysDo: [ :each | + vectorSize := vectorSize + 1. + dastTemp := dastContext tempNamed: each. + dastTemp isBlock + ifFalse: [ + self assert: (temp at: vectorSize) identicalTo: dastTemp ] + ifTrue: [ + self + assertFullBlock: (temp at: vectorSize) + equalsDASTBlock: dastTemp ] ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchTempVectorProcessResume [ + + | process | + self + interpreterOnMethodWithTempVector; + dastStepUntil: [ + (dastInterpreter currentNode isMessage and: [ + dastInterpreter currentNode selector = #+ and: [ + dastInterpreter currentNode arguments last isLiteralNode and: [ + dastInterpreter currentNode arguments last value = 3 ] ] ]) + not ]. + dastContext := dastInterpreter currentContext. + + context := dastContext asContext. + + process := Process + forContext: context + priority: Processor userInterruptPriority. + + [ dastContext isRoot ] whileFalse: [ + context := context sender. + dastContext := dastContext sender ]. + + process completeTo: context. + + self assert: process suspendedContext top equals: 9. + + self deny: process isTerminated. + + self shouldnt: [ process resume ] raise: Exception. + + self assert: process isTerminated +] + +{ #category : #tests } +DASTContextSwitchTests >> testBytecodeSwitchTempVectorStack [ + + | stack dastElement contextElement | + self + interpreterOnMethodWithTempVector; + dastStepUntil: [ + (dastInterpreter currentNode isMessage and: [ + dastInterpreter currentNode selector = #+ and: [ + dastInterpreter currentNode arguments last isLiteralNode and: [ + dastInterpreter currentNode arguments last value = 3 ] ] ]) + not ]. + dastContext := dastInterpreter currentContext. + + context := dastContext asContext. + + [ dastContext isRoot ] whileFalse: [ + stack := dastContext stack. + + self + assert: context stackPtr + equals: dastContext ir tempMap size + stack size. + self assert: dastContext ir tempMap size equals: context numTemps. + (Interval from: 1 to: stack size) do: [ :index | + dastElement := dastContext stack at: index. + contextElement := context at: context numTemps + index. + dastElement isBlock + ifFalse: [ self assert: contextElement identicalTo: dastElement ] + ifTrue: [ + self assertFullBlock: contextElement equalsDASTBlock: dastElement ] ]. + (Interval from: 1 to: dastContext ir tempMap size) do: [ :index | + | variableNames | + variableNames := (dastContext ir tempMap associations sorted: [ + :assoc1 + :assoc2 | assoc1 value <= assoc2 value ]) + collect: [ :each | each key ]. + contextElement := context at: index. + (variableNames at: index) = (dastContext allTemps at: index) key + ifTrue: [ + dastElement := (dastContext tempNamed: + (dastContext allTemps at: index) key) value. + dastElement isBlock + ifFalse: [ self assert: contextElement identicalTo: dastElement ] + ifTrue: [ + self + assertFullBlock: contextElement + equalsDASTBlock: dastElement ] ] + ifFalse: [ + | astScope | + astScope := context compiledCode ast scope. + self assert: contextElement isArray. + astScope tempVectorName = (variableNames at: index) + ifTrue: [ + astScope tempVectorVarNames withIndexDo: [ :each :indexVector | + dastElement := (dastContext tempNamed: each) value. + dastElement isBlock + ifFalse: [ + self + assert: (contextElement at: indexVector) + identicalTo: dastElement ] + ifTrue: [ + self + assertFullBlock: (contextElement at: indexVector) + equalsDASTBlock: dastElement ] ] ] + ifFalse: [ + self + assert: contextElement + identicalTo: + (context sender tempNamed: (variableNames at: index)) ] ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchCurrentNodeIsLastExecutedNode [ + + | node | + 4 timesRepeat: [ context := context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + node := dastContext executedNodes last. + + self assert: dastContext currentNode identicalTo: node +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchEvaluateAfterSwitchCanFindBindingsOfObjectsDefinedOutsideOfClosuresInContextThatDoesNotHaveDASTEquivalent [ + + | debuggerObjectForTest interpreter | + debuggerObjectForTest := StDebuggerObjectForTests new. + context := [ debuggerObjectForTest methodWithTempsAssignments ] + asContext. + interpreter := DASTInterpreter new. + dastContext := context asDASTContextInterpretedBy: interpreter. + interpreter initializeWithContext: dastContext. + + self assert: interpreter evaluate equals: 42 +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsBindings [ + + 4 timesRepeat: [ context := context step ]. + self + assert: ((context lookupTempVar: #a) readInContext: context) + equals: 40. + self + assert: ((context lookupTempVar: #b) readInContext: context) + equals: 2. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + self assert: (dastContext findLocalVariable: #a) value equals: 40. + self assert: (dastContext findLocalVariable: #b) value equals: 2 +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsBindingsRecursively [ + + | tempNames | + 4 timesRepeat: [ context := context step ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + tempNames := context tempNames. + tempNames do: [ :temp | + self + assert: ((context lookupTempVar: temp) readInContext: context) + identicalTo: (dastContext findLocalVariable: temp) value ]. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsReceiver [ + + 4 timesRepeat: [ context := context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + self assert: context receiver identicalTo: dastContext receiver +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsReceiversRecursively [ + "Tests fail because we NEED, in some way, to have an outer context. I need either to put the dead pharo context again OR to transform this dead context to a DAST context" + + 4 timesRepeat: [ context := context step ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + self assert: context receiver identicalTo: dastContext receiver. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsValueStack [ + + 6 timesRepeat: [ context := context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + self + assert: dastContext stack size + equals: context stackPtr - context numTemps. + (Interval from: 1 to: dastContext stack size) do: [ :index | + self + assert: (dastContext stack at: index) + identicalTo: (context at: context numTemps + index) ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchKeepsValueStackRecursively [ + + 6 timesRepeat: [ context := context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + self + assert: dastContext stack size + equals: context stackPtr - context numTemps. + (Interval from: 1 to: dastContext stack size) do: [ :index | + self + assert: (dastContext stack at: index) + identicalTo: (context at: context numTemps + index) ]. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchMessageNodeIsLastSourceNodeExecutedFromSender [ + + | node | + 4 timesRepeat: [ context := context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + self deny: dastContext sender isRoot. + node := context sender sourceNodeExecuted. + + self assert: dastContext messageNode identicalTo: node +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchPutsRootBeforeFirstInterestingContext [ + + 4 timesRepeat: [ context step ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + self deny: dastContext isRoot. + self deny: dastContext isBlockContext. + self + assert: dastContext methodOrBlock compiledCode + identicalTo: context compiledCode. + + self deny: dastContext sender isRoot. + self assert: dastContext sender isBlockContext. + self + assert: dastContext sender methodOrBlock nodeAST + equals: context sender compiledCode ast. + + self assert: dastContext sender sender isRoot +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchReceiverRemainsUnchanged [ + + | instVars oldInstVarValues newInstVarValues | + 4 timesRepeat: [ context := context step ]. + + instVars := context receiver class allInstVarNames. + oldInstVarValues := instVars collect: [ :inst | + context receiver instVarNamed: inst ]. + + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + newInstVarValues := instVars collect: [ :inst | + dastContext receiver instVarNamed: inst ]. + + oldInstVarValues withIndexDo: [ :each :index | + self assert: each identicalTo: (newInstVarValues at: index) ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchStepIsCorrect [ + + | pc node interpreter | + 4 timesRepeat: [ context := context step ]. + + pc := context pc. + dastContext := context asDASTContextInterpretedBy: + (interpreter := DASTInterpreter new). + node := context compiledCode sourceNodeForPC: context pc. + + interpreter initializeWithContext: dastContext. + + self assert: dastContext nodes top identicalTo: node. + self assert: dastContext canExecute. + self assert: interpreter currentContext identicalTo: dastContext. + + "one step to evaluate a (40), one step to evaluate b (2) and one step to compute the sum" + interpreter + stepInto; + stepInto; + stepInto. + + self assert: dastContext nodes top isReturn. + self assert: dastContext canExecute. + self assert: interpreter currentContext identicalTo: dastContext +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTempVectorBindings [ + + | dastTemp | + self + contextOnMethodWithTempVector; + bcStepUntil: [ + | node | + node := context compiledCode ast sourceNodeForPC: context pc. + (node isMessage and: [ + node selector = #+ and: [ + node arguments last isLiteralNode and: [ + node arguments last value = 3 ] ] ]) not ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + | tempNames | + tempNames := dastContext allTemps collect: [ :each | each key ]. + tempNames do: [ :temp | + dastTemp := (dastContext findLocalVariable: temp) value. + dastTemp isBlock + ifFalse: [ + self + assert: ((context lookupTempVar: temp) readInContext: context) + identicalTo: dastTemp ] + ifTrue: [ + | contextTemp | + contextTemp := (context lookupTempVar: temp) readInContext: + context. + self assertFullBlock: contextTemp equalsDASTBlock: dastTemp ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTempVectorEvaluateAfterSwitch [ + + | interpreter | + self + contextOnMethodWithTempVector; + bcStepUntil: [ + | node | + node := context compiledCode ast sourceNodeForPC: context pc. + (node isMessage and: [ + node selector = #+ and: [ + node arguments last isLiteralNode and: [ + node arguments last value = 3 ] ] ]) not ]. + interpreter := DASTInterpreter new. + dastContext := context asDASTContextInterpretedBy: interpreter. + interpreter initializeWithContext: dastContext. + + self assert: interpreter evaluate equals: 9 +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTempVectorFlatting [ + + | astScope temp dastTemp vectorSize | + self + contextOnMethodWithTempVector; + bcStepUntil: [ + | node | + node := context compiledCode ast sourceNodeForPC: context pc. + (node isMessage and: [ + node selector = #+ and: [ + node arguments last isLiteralNode and: [ + node arguments last value = 3 ] ] ]) not ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + astScope := dastContext methodOrBlock nodeAST scope. + astScope tempVector ifNotEmpty: [ + temp := context tempNamed: astScope tempVectorName. + self assert: temp isArray. + vectorSize := 0. + astScope tempVector keysDo: [ :each | + vectorSize := vectorSize + 1. + dastTemp := dastContext tempNamed: each. + dastTemp isBlock + ifFalse: [ + self assert: (temp at: vectorSize) identicalTo: dastTemp ] + ifTrue: [ + self + assertFullBlock: (temp at: vectorSize) + equalsDASTBlock: dastTemp ] ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTempVectorStack [ + + | stack dastElement contextElement | + self + contextOnMethodWithTempVector; + bcStepUntil: [ + | node | + node := context compiledCode ast sourceNodeForPC: context pc. + (node isMessage and: [ + node selector = #+ and: [ + node arguments last isLiteralNode and: [ + node arguments last value = 3 ] ] ]) not ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + stack := dastContext stack. + + (Interval from: 1 to: stack size) do: [ :index | + dastElement := dastContext stack at: index. + contextElement := context at: context numTemps + index. + dastElement isBlock + ifFalse: [ self assert: contextElement identicalTo: dastElement ] + ifTrue: [ + self assertFullBlock: contextElement equalsDASTBlock: dastElement ] ]. + + dastContext := dastContext sender. + context := context sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTopNodeIsNodeMappedToCurrentPC [ + + | pc node | + 4 timesRepeat: [ context := context step ]. + + pc := context pc. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + node := context compiledCode sourceNodeForPC: context pc. + + self assert: dastContext nodes top identicalTo: node +] + +{ #category : #tests } +DASTContextSwitchTests >> testInterpreterSwitchTopNodeIsNodeMappedToCurrentPCRecursively [ + + | pcs node | + 4 timesRepeat: [ context := context step ]. + + pcs := context stack collect: [ :ctx | ctx pc ]. + dastContext := context asDASTContextInterpretedBy: + DASTInterpreter new. + + [ dastContext isRoot ] whileFalse: [ + node := context compiledCode sourceNodeForPC: context pc. + + self assert: dastContext nodes top identicalTo: node. + context := context sender. + dastContext := dastContext sender ] +] + +{ #category : #tests } +DASTContextSwitchTests >> testOptimizedIfsBcToDAST [ + + | interpreter | + context := [ + | a | + a := 0. + 1 = 2 + ifFalse: [ a := a + 1 ] + ifTrue: [ a := a + 2 ]. + a ] asContext. + + 4 timesRepeat: [ context := context step; stepToSendOrReturn ]. + + interpreter := DASTInterpreter new. + dastContext := context asDASTContextInterpretedBy: interpreter. + interpreter initializeWithContext: dastContext. + + self assert: interpreter evaluate equals: 1 +] diff --git a/DebuggableASTInterpreter/DASTContextTests.class.st b/DebuggableASTInterpreter/DASTContextTests.class.st index b658604..6903394 100644 --- a/DebuggableASTInterpreter/DASTContextTests.class.st +++ b/DebuggableASTInterpreter/DASTContextTests.class.st @@ -2,17 +2,278 @@ Class { #name : #DASTContextTests, #superclass : #TestCase, #instVars : [ - 'context' + 'context', + 'aCompiledMethod', + 'aReceiver', + 'aSender', + 'anArgument', + 'aMethodContext', + 'pharoContext', + 'interpreterRoot', + 'rootContext', + 'interpreterMethod', + 'methodContext', + 'interpreterBlock', + 'blockContext' ], #category : #'DebuggableASTInterpreter-Tests' } +{ #category : #running } +DASTContextTests >> setUp [ + + super setUp. + + "Put here a common initialization logic for tests" + interpreterRoot := DASTInterpreter new. + interpreterRoot initializeWithProgram: + (RBParser parseExpression: '1'). + rootContext := interpreterRoot currentContext rootContext. + + interpreterMethod := DASTInterpreter new. + interpreterMethod initializeWithProgram: (RBParser parseExpression: + 'DASTInterpreterClassForTests new helperCallingHelperAddingPoints: 2@2 with: 3@3 '). + interpreterMethod + stepOver; + stepOver; + stepOver; + stepOver; + stepInto; + stepOver; + stepOver; + stepOver; + stepInto; + stepOver; + stepOver; + stepOver; + stepInto. + "stop at the beginning of helperMethodAddingPoints context" + methodContext := interpreterMethod currentContext. + + interpreterBlock := DASTInterpreter new. + interpreterBlock initializeWithProgram: (RBParser parseExpression: + '[ :each | [:point | point + (5 @ 8) ] value: each @ each ] value: 4'). + "stop at the beginning of the embedded block context" + interpreterBlock + stepOver; + stepOver; + stepInto; + stepOver; + stepOver; + stepOver; + stepOver; + stepInto. + blockContext := interpreterBlock currentContext +] + { #category : #tests } DASTContextTests >> testContextInitialization [ context := DASTContext new. self assert: context executedNodes isEmpty ] +{ #category : #tests } +DASTContextTests >> testDASTBlockContextAsContextHasSameResult [ + + | bcContext process result | + interpreterBlock + stepOver; + stepOver; + stepOver. + bcContext := blockContext asContext. + process := Process + forContext: bcContext + priority: Processor userInterruptPriority. + + result := interpreterBlock evaluate. + + process completeTo: bcContext sender. + self assert: process suspendedContext top equals: result. + + self shouldnt: [ process resume ] raise: [ Exception ] +] + +{ #category : #tests } +DASTContextTests >> testDASTBlockContextAsContextKeepsSameEquivalentPc [ + + | bcContext nextNode nodes | + interpreterBlock + stepOver; + stepOver; + stepOver. + bcContext := blockContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ blockContext isRoot ] whileFalse: [ + nodes := blockContext nodes copy. + nextNode := nodes pop. + [ blockContext methodOrBlock nodeAST firstPcForNode: nextNode ] + whileNil: [ nextNode := nodes pop ]. + + self + assert: bcContext pc + equals: + (blockContext methodOrBlock nodeAST firstPcForNode: nextNode). + + bcContext := bcContext sender. + blockContext := blockContext sender ] +] + +{ #category : #tests } +DASTContextTests >> testDASTBlockContextAsContextKeepsSameReceiverSenderAndArguments [ + + | arguments receiver bcContext bcMethod dastMethod | + bcContext := blockContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ blockContext isRoot ] whileFalse: [ + receiver := blockContext receiver. + arguments := blockContext arguments. + bcMethod := bcContext method. + dastMethod := blockContext methodOrBlock compiledCode. + self + assert: bcContext receiver identicalTo: receiver; + assertCollection: bcContext arguments hasSameElements: arguments; + assert: bcContext method sourceCode + equals: blockContext methodOrBlock compiledCode sourceCode. + + bcContext := bcContext sender. + blockContext := blockContext sender ]. + + self assert: blockContext isRoot +] + +{ #category : #tests } +DASTContextTests >> testDASTBlockContextAsContextKeepsSameStack [ + + | bcContext stack | + interpreterBlock + stepOver; + stepOver; + stepOver. + bcContext := blockContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ bcContext ] whileNotNil: [ + stack := blockContext stack. + + self + assert: bcContext stackPtr + equals: stack size + blockContext variablesDict size. + 1 to: stack size do: [ :each | + self assert: stack pop identicalTo: bcContext pop ]. + + bcContext := bcContext sender. + blockContext := blockContext sender ] +] + +{ #category : #tests } +DASTContextTests >> testDASTMethodContextAsContextHasSameResult [ + + | bcContext process result | + interpreterMethod + stepOver; + stepOver. + bcContext := methodContext asContext. + process := Process + forContext: bcContext + priority: Processor userInterruptPriority. + + result := interpreterMethod evaluate. + + process completeTo: bcContext sender. + self assert: process suspendedContext top equals: result. + + self shouldnt: [ process resume ] raise: [ Exception ] +] + +{ #category : #tests } +DASTContextTests >> testDASTMethodContextAsContextKeepsSameEquivalentPc [ + + | bcContext nextNode nodes | + interpreterMethod + stepOver; + stepOver. + bcContext := methodContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ methodContext isRoot ] whileFalse: [ + nodes := methodContext nodes copy. + nextNode := nodes pop. + [ methodContext methodOrBlock nodeAST firstPcForNode: nextNode ] + whileNil: [ nextNode := nodes pop ]. + + self + assert: bcContext pc + equals: + (methodContext methodOrBlock nodeAST firstPcForNode: nextNode). + + bcContext := bcContext sender. + methodContext := methodContext sender ] +] + +{ #category : #tests } +DASTContextTests >> testDASTMethodContextAsContextKeepsSameReceiverSenderAndArguments [ + + | arguments receiver bcContext | + bcContext := methodContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ methodContext isRoot ] whileFalse: [ + receiver := methodContext receiver. + arguments := methodContext arguments. + + self + assert: bcContext receiver identicalTo: receiver; + assertCollection: bcContext arguments hasSameElements: arguments; + assert: bcContext method + identicalTo: methodContext methodOrBlock compiledCode. + + bcContext := bcContext sender. + methodContext := methodContext sender ]. + + self assert: methodContext isRoot +] + +{ #category : #tests } +DASTContextTests >> testDASTMethodContextAsContextKeepsSameStack [ + + | bcContext stack | + interpreterMethod + stepOver; + stepOver. + bcContext := methodContext asContext. + + "We check that bcContext and its senders have the same receiver and arguments the DASTContext and its senders" + [ bcContext ] whileNotNil: [ + stack := methodContext stack. + + self + assert: bcContext stackPtr + equals: stack size + methodContext allTemps size. + 1 to: stack size do: [ :each | + self assert: stack pop identicalTo: bcContext pop ]. + + bcContext := bcContext sender. + methodContext := methodContext sender ] +] + +{ #category : #tests } +DASTContextTests >> testDASTRootContextAsContext [ + + | bcContext process | + self assert: rootContext sender isNil. + + bcContext := rootContext asContext. + + process := Process + forContext: bcContext + priority: Processor userInterruptPriority. + self shouldnt: [ process resume ] raise: [ BlockCannotReturn ]. + + self assert: process isTerminated +] + { #category : #stack } DASTContextTests >> testStackPopEmpty [ | stack | diff --git a/DebuggableASTInterpreter/DASTException.class.st b/DebuggableASTInterpreter/DASTException.class.st index f5fc64b..56662dd 100644 --- a/DebuggableASTInterpreter/DASTException.class.st +++ b/DebuggableASTInterpreter/DASTException.class.st @@ -4,9 +4,6 @@ If I'm signaled, the interpreter evaluation should pause " Class { #name : #DASTException, - #superclass : #Object, - #instVars : [ - 'messageText' - ], + #superclass : #OupsNullException, #category : #'DebuggableASTInterpreter-Exceptions' } diff --git a/DebuggableASTInterpreter/DASTInterpreter.class.st b/DebuggableASTInterpreter/DASTInterpreter.class.st index 3e73c77..742c878 100644 --- a/DebuggableASTInterpreter/DASTInterpreter.class.st +++ b/DebuggableASTInterpreter/DASTInterpreter.class.st @@ -14,6 +14,16 @@ Class { #category : #'DebuggableASTInterpreter-Core' } +{ #category : #'as yet unclassified' } +DASTInterpreter class >> startFromContext: aContext [ + + | interpreter | + interpreter := self new. + + ^ interpreter initializeWithContext: + (aContext asDASTContextInterpretedBy: interpreter) +] + { #category : #accessing } DASTInterpreter >> astCache: aCollection [ astCache := aCollection @@ -113,29 +123,8 @@ DASTInterpreter >> increasePC [ DASTInterpreter >> initializeWithContext: aDASTContext [ "initialize the interpreter to resume the execution from the context got as argument" - | visitor nodes rootContext aRBNode aCollection| -self halt. - astCache := IdentityDictionary new. programCounter := 0. - visitor := DASTPostOrderTreeVisitor new. - - (aRBNode methodNode body addReturn; yourself) acceptVisitor: visitor. - nodes := visitor stack. - rootContext := DASTContextRootSmalltalk new - evaluator: self evaluator; - yourself. - "ugly method necessary because we are putting the root expression of the AST inside a return and sending it the message value" - self flag: 'update next call'. - " Set the first method (noMethod) context evaluation. The receiver is nil " - currentContext := DASTMethodContext new - receiver: self evaluator nilObject; - parent: rootContext; - methodOrBlock: (DASTMethod new initializeWith: nodes last methodNode evaluator: self evaluator); - nodes: nodes; - sender: rootContext; - temps: aCollection; - evaluator: self evaluator; - yourself. + self currentContext: aDASTContext ] @@ -167,11 +156,23 @@ DASTInterpreter >> initializeWithProgram: aRBNode inContext: aDASTContext [ { #category : #initialization } DASTInterpreter >> initializeWithProgram: aRBNode withTemps: aCollection astCache: anIdentityDictionary [ - - astCache := anIdentityDictionary. + + | compiledMethod doItMethodNode | + astCache := anIdentityDictionary. programCounter := 0. - currentContext := DASTContext newNoMethodContextWithProgram: aRBNode temps: aCollection evaluator: self evaluator + "aRBNode methodNode generateWithSource." + compiledMethod := UndefinedObject compiler + noPattern: true; + compile: aRBNode methodNode source. + doItMethodNode := compiledMethod ast. + "(doItMethodNode + doSemanticAnalysis; + ir)" "generate". + currentContext := DASTContext + newNoMethodContextWithProgram: doItMethodNode body + temps: aCollection + evaluator: self evaluator ] { #category : #testing } @@ -406,6 +407,14 @@ DASTInterpreter >> visitLiteralVariableNode: aRBVariableNode [ ^ self visitGlobalNode: aRBVariableNode ] +{ #category : #visiting } +DASTInterpreter >> visitLocalVariableNode: aNode [ + + "call visitTemporaryNode: for backward compatibility" + + ^ self visitTemporaryNode: aNode +] + { #category : #visiting } DASTInterpreter >> visitMessageNode: aRBMessageNode [ | arguments receiver method newContext | diff --git a/DebuggableASTInterpreter/DASTInterpreterClassForTests.class.st b/DebuggableASTInterpreter/DASTInterpreterClassForTests.class.st index 84c2816..63ab57d 100644 --- a/DebuggableASTInterpreter/DASTInterpreterClassForTests.class.st +++ b/DebuggableASTInterpreter/DASTInterpreterClassForTests.class.st @@ -81,6 +81,18 @@ DASTInterpreterClassForTests >> getVariableDeclaredInMethod [ ^ a ] +{ #category : #helpers } +DASTInterpreterClassForTests >> helperAddingPoints: point1 with: point2 [ + + ^ point1 + point2 +] + +{ #category : #helpers } +DASTInterpreterClassForTests >> helperCallingHelperAddingPoints: point1 with: point2 [ + + ^ self helperAddingPoints: point1 with: point2 +] + { #category : #tests } DASTInterpreterClassForTests >> initialize [ |x| diff --git a/DebuggableASTInterpreter/DASTInterpreterTests.class.st b/DebuggableASTInterpreter/DASTInterpreterTests.class.st index ee27ea3..7e8dd78 100644 --- a/DebuggableASTInterpreter/DASTInterpreterTests.class.st +++ b/DebuggableASTInterpreter/DASTInterpreterTests.class.st @@ -274,6 +274,14 @@ DASTInterpreterTests >> testIfTrue [ equals: 3 ] +{ #category : #'tests-contexts' } +DASTInterpreterTests >> testIfTrueIfFalse [ + + self + assert: (self evaluateProgram: 'false ifTrue: [ ^3] ifFalse: [ ^2]') + equals: 2 +] + { #category : #'tests-blocks' } DASTInterpreterTests >> testIfTrueThatWritesLocalVar [ @@ -929,6 +937,15 @@ DASTInterpreterTests >> testVarsLocalVariableModifiedInsideWhileTrueAndValueBloc ] +{ #category : #'tests-blocks' } +DASTInterpreterTests >> testWhileTrue [ + + self + assert: (self evaluateProgram: + '|a| a := 0. [ a < 5 ] whileTrue: [a := a + 1 ]. ^ a') + equals: 5 +] + { #category : #'tests-self' } DASTInterpreterTests >> testYourSelfTwice [ diff --git a/DebuggableASTInterpreter/DASTMethod.class.st b/DebuggableASTInterpreter/DASTMethod.class.st index aa8ade0..e2dced2 100644 --- a/DebuggableASTInterpreter/DASTMethod.class.st +++ b/DebuggableASTInterpreter/DASTMethod.class.st @@ -13,6 +13,12 @@ DASTMethod >> bodyOffset [ ^ self selectorFormatted size "+ (self isNoMethod ifTrue: [ 1 ] ifFalse: [ 0 ])" ] +{ #category : #accessing } +DASTMethod >> compiledCode [ + + ^ self nodeAST compiledMethod +] + { #category : #accessing } DASTMethod >> evaluatePrimitive [ ^ evaluatePrimitive ifNil: [ evaluatePrimitive := true ] @@ -81,7 +87,7 @@ DASTMethod >> isNamedPrimitive [ { #category : #testing } DASTMethod >> isNoMethod [ - ^ self selector = #noMethod + ^ self selector = #DoIt ] { #category : #accessing } diff --git a/DebuggableASTInterpreter/DASTMethodContext.class.st b/DebuggableASTInterpreter/DASTMethodContext.class.st index 08c4e64..7f1f9a1 100644 --- a/DebuggableASTInterpreter/DASTMethodContext.class.st +++ b/DebuggableASTInterpreter/DASTMethodContext.class.st @@ -19,6 +19,18 @@ DASTMethodContext >> allTemps [ ^ self variablesDict associations ] +{ #category : #accessing } +DASTMethodContext >> arguments [ + + ^ (self method ast arguments collect: [ :each | each name ]) collect: [ :each | (self findLocalVariable: each) value ] +] + +{ #category : #testing } +DASTMethodContext >> belongsToDoIt [ + + ^ self methodOrBlock isNoMethod +] + { #category : #'API-lookup' } DASTMethodContext >> findLocalVariable: aName [ ^ variablesDict @@ -78,6 +90,12 @@ DASTMethodContext >> initializeContext [ ] +{ #category : #helpers } +DASTMethodContext >> ir [ + + ^ self methodOrBlock nodeAST compiledMethod ir +] + { #category : #initialization } DASTMethodContext >> isBlockContext [ ^ false @@ -121,8 +139,3 @@ DASTMethodContext >> removePrimitiveFromMethod [ self methodOrBlock evaluatePrimitive: false ] - -{ #category : #accessing } -DASTMethodContext >> temps: aCollection [ - aCollection do: [ :assoc | self at: assoc key put: assoc value ] -] diff --git a/DebuggableASTInterpreter/DASTNoMethod.class.st b/DebuggableASTInterpreter/DASTNoMethod.class.st new file mode 100644 index 0000000..b5ee4da --- /dev/null +++ b/DebuggableASTInterpreter/DASTNoMethod.class.st @@ -0,0 +1,19 @@ +Class { + #name : #DASTNoMethod, + #superclass : #DASTMethod, + #category : #'DebuggableASTInterpreter-Closures' +} + +{ #category : #testing } +DASTNoMethod >> isNoMethod [ + + ^ true +] + +{ #category : #accessing } +DASTNoMethod >> nodeAST: aRBNode [ + + super nodeAST: aRBNode. + "Not necessary anymore as the interpreter compiles DoIts properly" + "nodeAST doSemanticAnalysis" +] diff --git a/DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st b/DebuggableASTInterpreter/DASTPostOrderTreeVisitor.class.st index c4dba67..6ceb325 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 [ @@ -157,7 +165,7 @@ DASTPostOrderTreeVisitor >> visitSuperNode: aRBSuperNode [ ^ stack push: aRBSuperNode ] -{ #category : #'as yet unclassified' } +{ #category : #visiting } DASTPostOrderTreeVisitor >> visitTemporaryNode: aRBTemporaryNode [ stack push: aRBTemporaryNode ] diff --git a/DebuggableASTInterpreter/StDebuggerObjectForTests.extension.st b/DebuggableASTInterpreter/StDebuggerObjectForTests.extension.st new file mode 100644 index 0000000..98133cc --- /dev/null +++ b/DebuggableASTInterpreter/StDebuggerObjectForTests.extension.st @@ -0,0 +1,10 @@ +Extension { #name : #StDebuggerObjectForTests } + +{ #category : #'*DebuggableASTInterpreter' } +StDebuggerObjectForTests >> methodWithTempsAssignments [ + + | a b | + a := 40. + b := 2. + ^ a + b +] diff --git a/DebuggableASTInterpreter/UndefinedObject.extension.st b/DebuggableASTInterpreter/UndefinedObject.extension.st new file mode 100644 index 0000000..497cc9b --- /dev/null +++ b/DebuggableASTInterpreter/UndefinedObject.extension.st @@ -0,0 +1,16 @@ +Extension { #name : #UndefinedObject } + +{ #category : #'*DebuggableASTInterpreter' } +UndefinedObject >> asDASTContextInterpretedBy: aDastInterpreter [ + + ^ DASTContextRootSmalltalk new + currentNode: (RBMessageNode + receiver: (RBLiteralValueNode value: nil) + selector: #value); + yourself +] + +{ #category : #'*DebuggableASTInterpreter' } +UndefinedObject >> nodeForCurrentPC [ + ^ nil +]