diff --git a/Sindarin-Tests/SindarinDebuggerTest.class.st b/Sindarin-Tests/SindarinDebuggerTest.class.st index c2dbaa6..21bffac 100644 --- a/Sindarin-Tests/SindarinDebuggerTest.class.st +++ b/Sindarin-Tests/SindarinDebuggerTest.class.st @@ -239,6 +239,23 @@ SindarinDebuggerTest >> helperMethodWithBlockWithNoReturn [ ^ 43 ] +{ #category : #helpers } +SindarinDebuggerTest >> helperMethodWithDoubleAssignment [ + + | b a | + a := b := 1 +] + +{ #category : #helpers } +SindarinDebuggerTest >> helperMethodWithEmbeddedBlock [ + + | a | + a := 1. + [ :each | a := a + each. [ a := a + 1 ]. a * 42 ]. + a := a + 2. + ^ a * 42 +] + { #category : #helpers } SindarinDebuggerTest >> helperMethodWithEvaluatedBlock [ @@ -250,6 +267,36 @@ SindarinDebuggerTest >> helperMethodWithEvaluatedBlock [ ] +{ #category : #helpers } +SindarinDebuggerTest >> helperMethodWithIfTrueBlock [ + + | a | + a := 1. + a = 2 ifTrue: [ a := 3 ]. + a := 4 +] + +{ #category : #tests } +SindarinDebuggerTest >> helperMethodWithIfTrueIfFalse [ + + | a | + a := true. + a + ifFalse: [ a := 1 ] + ifTrue: [ a := 2 ]. + a := 3 +] + +{ #category : #helpers } +SindarinDebuggerTest >> helperMethodWithNotEvaluatedBlock [ + + | a | + a := 1. + [ a := a + 1 ]. + a := a + 2. + ^ a * 42 +] + { #category : #helpers } SindarinDebuggerTest >> helperMethodWithSeveralInstructionsInBlock [ @@ -386,6 +433,156 @@ SindarinDebuggerTest >> testCanStillExecuteWhenAimedNodePcIsBeforeInAnyContext [ self deny: (sdbg canStillExecute: aimedNodeOutsideContext) ] +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcAssociatedToMethodOrSequenceNodeKeepsStackAsItIs [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ + self helperMethodWithDoubleAssignment ]. + + scdbg + step; + stepOver. + newNode := scdbg methodNode. + newPc := scdbg methodNode firstPcForNode: newNode. + expectedStackTop := scdbg topStack. + + scdbg pc: newPc. + + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self assert: scdbg topStack equals: expectedStackTop +] + +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcInTheMiddleOfStatementSkipsTheBeginningOfStatement [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver; + stepOver; + stepOver. + "pc of Point x: y:" + newNode := scdbg node. + newPc := scdbg pc. + expectedStackTop := scdbg topStack. + + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver. + "pc of a := 5" + + self assert: (scdbg temporaryNamed: #a) equals: 1. + + scdbg pc: newPc. + "It should skip the assignment a:=5 AND skip the beginning of the statement ('3' asInteger)" + + self assert: (scdbg temporaryNamed: #a) equals: 1. + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self deny: scdbg topStack equals: expectedStackTop. + self assert: scdbg topStack equals: '3' "topStack is nil because the message send asInteger to the receiver '3' has been skipped" +] + +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcKeepsSameStateAndPushesCorrectElementsOnStack [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver. + "pc of a := 5" + newNode := scdbg node. + newPc := scdbg pc. + expectedStackTop := scdbg topStack. + scdbg + stepOver; + stepOver. + + self assert: (scdbg temporaryNamed: #a) equals: 5. + + scdbg pc: newPc. + + self assert: (scdbg temporaryNamed: #a) equals: 5. + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self assert: scdbg topStack equals: expectedStackTop +] + +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcRaisesErrorWhenPcIsGreaterThanEndPC [ + + | oldPC sdbg | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver; + stepOver. + oldPC := sdbg pc. + self + shouldnt: [ sdbg pc: sdbg method endPC ] raise: NotValidPcError; + deny: sdbg pc equals: oldPC. + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver; + stepOver. + oldPC := sdbg pc. + self + should: [ sdbg pc: sdbg method endPC + 1 ] raise: NotValidPcError; + assert: sdbg pc equals: oldPC +] + +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcRaisesErrorWhenPcIsLowerThanInitialPC [ + + | scdbg | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver; + stepOver. + + self shouldnt: [ scdbg pc: scdbg method initialPC ] raise: NotValidPcError. + + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver; + stepOver. + + self should: [ scdbg pc: scdbg method initialPC - 1 ] raise: NotValidPcError. +] + +{ #category : #tests } +SindarinDebuggerTest >> testChangingPcToNonExistingBytecodeOffsetGoesToPreviousPcWithExistingBytecodeOffset [ + + | scdbg newPc newNode | + scdbg := SindarinDebugger debug: [ + self helperMethodWithDoubleAssignment ]. + + scdbg step. + "pc of b := 1 from `a:= b:= 1` This is associated to the pc of a storeIntoTemp bytecode, of length 2 bytes. So we add 1 to get a pc that is in the middle of the bytecode" + newNode := scdbg methodNode statements first value. + newPc := (scdbg methodNode firstPcForNode: newNode) + 1. + + self assert: (scdbg methodNode sourceNodeForPC: newPc) identicalTo: newNode. + + scdbg pc: newPc. + + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc - 1. +] + { #category : #tests } SindarinDebuggerTest >> testContext [ | scdbg | @@ -556,6 +753,581 @@ SindarinDebuggerTest >> testMethod [ self assert: scdbg method equals: String>>#asInteger ] +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeInTheMiddleOfStatementSkipsTheBeginningOfStatement [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver; + stepOver; + stepOver. + "pc of Point x: y:" + newNode := scdbg node. + newPc := scdbg pc. + expectedStackTop := scdbg topStack. + + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver. + "pc of a := 5" + + self assert: (scdbg temporaryNamed: #a) equals: 1. + + scdbg moveToNode: newNode. + "It should skip the assignment a:=5 AND skip the beginning of the statement ('3' asInteger)" + + self assert: (scdbg temporaryNamed: #a) equals: 1. + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self deny: scdbg topStack equals: expectedStackTop. + self assert: scdbg topStack equals: '3' "topStack is nil because the message send asInteger to the receiver '3' has been skipped" +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeKeepsSameStateAndPushesCorrectElementsOnStack [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver. + "pc of a := 5" + newNode := scdbg node. + newPc := scdbg pc. + expectedStackTop := scdbg topStack. + scdbg + stepOver; + stepOver. + + self assert: (scdbg temporaryNamed: #a) equals: 5. + + scdbg moveToNode: newNode. + + self assert: (scdbg temporaryNamed: #a) equals: 5. + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self assert: scdbg topStack equals: expectedStackTop +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeKeepsStackWhenAimedNodeIsMethodNode [ + + | scdbg newPc newNode expectedStackTop | + scdbg := SindarinDebugger debug: [ + self helperMethodWithDoubleAssignment ]. + + scdbg + step; + stepOver. + "pc of a := 5" + newNode := scdbg methodNode. + newPc := scdbg methodNode firstPcForNode: scdbg methodNode. + expectedStackTop := scdbg topStack. + + scdbg moveToNode: newNode. + + self assert: scdbg node equals: newNode. + self assert: scdbg pc equals: newPc. + self assert: scdbg topStack equals: expectedStackTop +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeKeepsStackWhenAimedNodeIsMethodNodeThatDoesNotHaveAssociatedPC [ + + | scdbg newPc newNode realPC realNode | + scdbg := SindarinDebugger debug: [ self helperMethod1 ]. + + scdbg + step; + stepOver. + "pc of a := 5" + newNode := scdbg methodNode. + newPc := scdbg methodNode firstPcForNode: scdbg methodNode. + + + self assert: newPc isNil. + + scdbg moveToNode: newNode. + + realPC := scdbg pc. + realNode := scdbg node. + + self assert: scdbg pc equals: scdbg method endPC. + self + assert: scdbg node + identicalTo: (scdbg methodNode sourceNodeForPC: scdbg pc) +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeRaisesErrorWhenNodeIsNotIdenticalToANodeInMethod [ + + | oldNode sdbg aimedNode | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver. + aimedNode := sdbg node. + sdbg + stepOver; + stepOver. + oldNode := sdbg node. + self + shouldnt: [ sdbg moveToNode: aimedNode ] raise: NodeNotInASTError; + assert: sdbg node equals: aimedNode. + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver; + stepOver. + oldNode := sdbg node. + self + should: [ sdbg moveToNode: (RBLiteralValueNode value: 1) ] + raise: NodeNotInASTError; + assert: sdbg node equals: oldNode +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeRaisesErrorWhenNodeIsNotInMethod [ + + | oldNode sdbg | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver; + stepOver. + oldNode := sdbg node. + self + shouldnt: [ sdbg moveToNode: sdbg methodNode statements last ] + raise: NodeNotInASTError; + deny: sdbg node equals: oldNode. + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg + step; + stepOver; + stepOver. + oldNode := sdbg node. + self + should: [ sdbg moveToNode: (RBLiteralValueNode value: 2) ] + raise: NodeNotInASTError; + assert: sdbg node equals: oldNode +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenFromNonInlinedBlockToOuterContext [ + + | oldNode sdbg aimedNode oldContext aimedPC methodNode | + sdbg := SindarinDebugger debug: [ + self helperMethodWithNotEvaluatedBlock ]. + sdbg + step; + stepOver; + stepOver. + + "stops on block creation" + oldNode := sdbg node. + oldContext := sdbg context. + methodNode := sdbg methodNode. + + "We want to move to node 'a + 1' in [a := a +1]" + aimedNode := sdbg methodNode statements second statements first value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg context home identicalTo: oldContext. + self + assert: sdbg methodNode + identicalTo: methodNode statements second. + + sdbg stepOver. + + "2 is going to be assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 2. + + sdbg moveToNode: methodNode statements third. + "We jump to node outside of block" + self assert: sdbg methodNode identicalTo: methodNode. + self assert: sdbg node identicalTo: methodNode statements third. + "We went back to the home context" + self assert: sdbg context identicalTo: oldContext. + "2 has not been assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 1 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenFromNonInlinedEmbeddedBlockToHomeContext [ + + | oldNode sdbg aimedNode oldContext aimedPC methodNode | + sdbg := SindarinDebugger debug: [ + self helperMethodWithEmbeddedBlock ]. + sdbg + step; + stepOver; + stepOver. + + "stops on block creation" + oldNode := sdbg node. + oldContext := sdbg context. + methodNode := sdbg methodNode. + + "We want to move to node 'a + 1' in [a := a +1]" + aimedNode := sdbg methodNode statements second statements second statements first value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg context home identicalTo: oldContext. + self + assert: sdbg methodNode + identicalTo: methodNode statements second statements second. + + sdbg stepOver. + + "2 is going to be assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 2. + + sdbg moveToNode: methodNode statements third. + "We jump to node in home context of embedded block" + self assert: sdbg methodNode identicalTo: methodNode. + self assert: sdbg node identicalTo: methodNode statements third. + "We went back to the home context" + self assert: sdbg context identicalTo: oldContext. + "2 has not been assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 1 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenFromNonInlinedEmbeddedBlockToNodeThatIsNotInHomeContext [ + + | oldNode oldPC sdbg aimedNode oldContext aimedPC methodNode | + sdbg := SindarinDebugger debug: [ self helperMethodWithEmbeddedBlock ]. + sdbg + step; + stepOver; + stepOver. + + "stops on block creation" + oldNode := sdbg node. + oldContext := sdbg context. + methodNode := sdbg methodNode. + + "We want to move to node 'a + 1' in [a := a +1]" + aimedNode := sdbg methodNode statements second statements second + statements first value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg context home identicalTo: oldContext. + self + assert: sdbg methodNode + identicalTo: methodNode statements second statements second. + + sdbg stepOver. + + "2 is going to be assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 2. + + oldNode := sdbg node. + oldPC := sdbg pc. + oldContext := sdbg context. + + self + should: [ sdbg moveToNode: (RBLiteralValueNode value: 1) ] + raise: NodeNotInASTError. + "We jump to node in home context of embedded block" + self assert: sdbg node identicalTo: oldNode. + "We went back to the home context" + self assert: sdbg context identicalTo: oldContext. + "2 has not been assigned to a" + self assert: (sdbg temporaryNamed: #a) equals: 1. + self assert: sdbg topStack equals: 2 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsInBlockThatCreatesContextAndBlockHasBeenCreated [ + + | oldNode sdbg aimedNode oldContext aimedPC | + sdbg := SindarinDebugger debug: [ + self helperMethodWithNotEvaluatedBlock ]. + sdbg + step; + stepOver; + stepOver; + stepOver. + + sdbg moveToNode: sdbg methodNode statements first. + + "It is going to execute the comparison a := 1" + oldNode := sdbg node. + oldContext := sdbg context. + + "We want to enter the block, to get to execute a + 1 in the block" + aimedNode := sdbg methodNode statements second body statements first + value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg node identicalTo: aimedNode. + self assert: sdbg context sender identicalTo: oldContext. + + sdbg + stepOver; + stepOver; + stepOver. + + self assert: (sdbg temporaryNamed: #a) equals: 2. + + "When you perform a stepOver, you quit the block and continue right where you were before moving to caret" + self assert: sdbg node identicalTo: sdbg methodNode statements third value. + self assert: sdbg context identicalTo: oldContext. + self assert: sdbg topStack equals: 2 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsInBlockThatCreatesContextAndBlockHasBeenCreatedBackward [ + + | oldNode sdbg aimedNode oldContext aimedPC | + sdbg := SindarinDebugger debug: [ + self helperMethodWithNotEvaluatedBlock ]. + sdbg + step; + stepOver; + stepOver; + stepOver; + stepOver. + + "It is going to execute a := a + 2" + oldNode := sdbg node. + oldContext := sdbg context. + + "We want to enter the block, to get to execute a + 1 in the block" + aimedNode := sdbg methodNode statements second body statements first + value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg node identicalTo: aimedNode. + self assert: sdbg context sender identicalTo: oldContext. + + sdbg + stepOver; + stepOver; + stepOver. + + self assert: (sdbg temporaryNamed: #a) equals: 2. + + "When you perform a stepOver, you quit the block and continue right where you were before moving to caret" + self assert: sdbg node identicalTo: oldNode value. + self assert: sdbg context identicalTo: oldContext. + self assert: sdbg topStack equals: 2 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsInIfTrueIfFalseBlock [ + + | oldNode sdbg aimedNode oldContext aimedPC | + sdbg := SindarinDebugger debug: [ self helperMethodWithIfTrueBlock ]. + sdbg + step; + stepOver. + + "It is going to execute the comparison a = 2" + oldNode := sdbg node. + oldContext := sdbg context. + + "We want to enter the block, to get to execute a:=3" + aimedNode := sdbg methodNode statements second arguments first body + statements first. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNotNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg node identicalTo: aimedNode. + self assert: sdbg pc identicalTo: aimedPC. + self assert: sdbg context identicalTo: oldContext. + + sdbg stepOver. + + self assert: (sdbg temporaryNamed: #a) equals: 3. + + sdbg stepOver. + "When you perform a stepOver, you quit the block and continue just after the ifTrue: message" + self assert: (sdbg temporaryNamed: #a) equals: 4 +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsLiteralOrVariableExecutesAssociatedBytecodesBecauseRelatedToStack [ + + | oldNode sdbg aimedNode siblingsAfterAimedNode indexOfAimedNode realNode indexOfRealNode | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg step. + oldNode := sdbg node. + "This is the literal variable Point from `Point x: 5 y: '3' asInteger" + aimedNode := sdbg methodNode statements last value receiver. + indexOfAimedNode := sdbg methodNode allChildrenPostOrder identityIndexOf: aimedNode. + siblingsAfterAimedNode := sdbg methodNode allChildrenPostOrder + withIndexSelect: [ :value :index | + index > indexOfAimedNode ]. + + self deny: (sdbg methodNode pcsForNode: aimedNode) isEmpty. + self assert: aimedNode isVariable. + + sdbg moveToNode: aimedNode. + + realNode := sdbg node. + indexOfRealNode := siblingsAfterAimedNode indexOf: realNode. + + self deny: realNode identicalTo: aimedNode. + siblingsAfterAimedNode + from: 1 + to: indexOfRealNode - 1 + do: [ :each | + self assert: (each isVariable or: [ each isLiteralNode ]) ]. + + self deny: (realNode isLiteralNode or: [ realNode isVariable ]) +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsLiteralOrVariableThatHasNoAssociatedBytecodesMovesToNextNodeThatIsNotLiteralNorVariableThatHasAnAssociatedPC [ + + | oldNode sdbg aimedNode siblingsAfterAimedNode indexOfAimedNode realNode indexOfRealNode | + sdbg := SindarinDebugger debug: [ + self helperMethodWithDoubleAssignment ]. + sdbg step. + oldNode := sdbg node. + "This is the variable node b from `a:= b:= 1`" + aimedNode := sdbg methodNode statements first value variable. + indexOfAimedNode := sdbg methodNode allChildrenPostOrder identityIndexOf: + aimedNode. + siblingsAfterAimedNode := sdbg methodNode allChildrenPostOrder + withIndexSelect: [ :value :index | + index > indexOfAimedNode ]. + + self assert: (sdbg methodNode pcsForNode: aimedNode) isEmpty. + + sdbg moveToNode: aimedNode. + + realNode := sdbg node. + indexOfRealNode := siblingsAfterAimedNode identityIndexOf: realNode. + + self deny: realNode identicalTo: aimedNode. + siblingsAfterAimedNode + from: 1 + to: indexOfRealNode - 1 + do: [ :each | + self assert: (each isVariable or: [ + each isLiteralNode or: [ + (sdbg methodNode pcsForNode: each) isEmpty ] ]) ]. + + " Why doesn't it work ?? + self deny: (realNode isLiteralNode or: [ realNode isVariable or: [ (sdbg methodNode pcsForNode: realNode) isEmpty  ] ]) " + + self + deny: realNode isLiteralNode; + deny: realNode isVariable; + deny: (sdbg methodNode pcsForNode: realNode) isEmpty +] + +{ #category : #tests } +SindarinDebuggerTest >> testMoveToNodeWhenNodeIsNonInlinedAndEmbeddedInNonInlinedBlock [ + + | oldNode sdbg aimedNode oldContext aimedPC methodNode | + sdbg := SindarinDebugger debug: [ + self helperMethodWithEmbeddedBlock ]. + sdbg + step; + stepOver; + stepOver. + + "stops on outer block creation" + oldNode := sdbg node. + oldContext := sdbg context. + methodNode := sdbg methodNode. + + "We want to move to node 'a + 1' in [a := a +1] (embedded block)" + aimedNode := sdbg methodNode statements second statements second statements first value. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + self assert: aimedPC isNil. + self assert: (sdbg temporaryNamed: #a) equals: 1. + + sdbg moveToNode: aimedNode. + + self assert: (sdbg temporaryNamed: #a) equals: 1. + + self assert: sdbg node identicalTo: aimedNode. + self assert: sdbg context home identicalTo: oldContext. + self assert: sdbg methodNode identicalTo: methodNode statements second statements second. + + sdbg + stepOver; + stepOver; + stepOver. + + self assert: (sdbg temporaryNamed: #a) equals: 2. + + "When you perform a stepOver, you quit the block and continue after the embedded block creation in the embedding block context" + self assert: sdbg methodNode identicalTo: methodNode statements second. + self assert: sdbg node identicalTo: methodNode statements second statements third. + self assert: sdbg context sender identicalTo: oldContext. + + sdbg + stepOver; + stepOver; + stepOver. + + self assert: (sdbg temporaryNamed: #a) equals: 2. + + "When you perform stepOver again, you quit the embedding block and continue after the embedding block creation in the old context" + self assert: sdbg methodNode identicalTo: methodNode. + self assert: sdbg node identicalTo: sdbg methodNode statements third. + self assert: sdbg context identicalTo: oldContext. +] + { #category : #tests } SindarinDebuggerTest >> testNode [ | node scdbg | @@ -885,6 +1657,59 @@ SindarinDebuggerTest >> testSkipToPcDoesNotLoopWhenAimedPcIsBeforeCurrentPc [ self assert: sdbg pc equals: pcBeforeSkip. ] +{ #category : #tests } +SindarinDebuggerTest >> testSkipUpToIgnoresJumps [ + + | sdbg aimedNode aimedPC a | + sdbg := SindarinDebugger debug: [ self helperMethodWithIfTrueIfFalse ]. + + sdbg step. + + aimedNode := sdbg methodNode statements second arguments first + statements first. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + a := sdbg temporaryNamed: #a. + + self assert: a isNil. + + sdbg skipUpToNode: aimedNode. + + self + assert: a isNil; + assert: sdbg node identicalTo: aimedNode; + assert: sdbg pc equals: aimedPC. + + aimedNode := sdbg methodNode statements second arguments second + statements first. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + a := sdbg temporaryNamed: #a. + + self assert: a isNil. + + sdbg skipUpToNode: aimedNode . + + self + assert: a isNil; + assert: sdbg node identicalTo: aimedNode; + assert: sdbg pc equals: aimedPC. + + aimedNode := sdbg methodNode statements third. + aimedPC := sdbg methodNode firstPcForNode: aimedNode. + + a := sdbg temporaryNamed: #a. + + self assert: a isNil. + + sdbg skipUpToNode: aimedNode. + + self + assert: a isNil; + assert: sdbg node identicalTo: aimedNode; + assert: sdbg pc equals: aimedPC +] + { #category : #'tests - skipping' } SindarinDebuggerTest >> testSkipUpToNode [ | dbg realExecPC realValueOfA realExecNode realExecTopStack | @@ -1077,6 +1902,41 @@ SindarinDebuggerTest >> testStack [ self assert: (scdbg stack at: 2) equals: context1 ] +{ #category : #tests } +SindarinDebuggerTest >> testStatementNodeContaining [ + + | sdbg | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg step; stepOver; stepOver; stepOver. "pc of Point x: y:" + + self assert: (sdbg statementNodeContaining: sdbg node) identicalTo: sdbg methodNode statements last +] + +{ #category : #tests } +SindarinDebuggerTest >> testStatementNodeContainingReturnsStatementNodeThatContainsTheIdenticalSubtree [ + + | sdbg | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg step. + + "1 is in the tree but it should return its parent only if we provide the exact literal node" + self + should: [ sdbg statementNodeContaining: (RBLiteralNode value: 1) ] + raise: NodeNotInASTError +] + +{ #category : #tests } +SindarinDebuggerTest >> testStatementNodeContainingWhenNodeIsNotInAST [ + + | sdbg | + sdbg := SindarinDebugger debug: [ self helperMethod1 ]. + sdbg step. + + self + should: [ sdbg statementNodeContaining: (RBLiteralNode value: 2) ] + raise: NodeNotInASTError +] + { #category : #tests } SindarinDebuggerTest >> testStep [ | node scdbg | diff --git a/Sindarin/Context.extension.st b/Sindarin/Context.extension.st new file mode 100644 index 0000000..5621831 --- /dev/null +++ b/Sindarin/Context.extension.st @@ -0,0 +1,18 @@ +Extension { #name : #Context } + +{ #category : #'*Sindarin' } +Context >> stepToSendOrReturnOrJump [ + + "Simulate the execution of bytecodes until either sending a message or + returning a value to the receiver (that is, until switching contexts)." + + | stream context | + stream := InstructionStream on: method pc: pc. + [ + self isDead or: [ + stream willSendOrReturnOrStoreOrCreateBlock or: [ stream willJump ] ] ] + whileFalse: [ + context := stream interpretNextInstructionFor: self. + context == self ifFalse: [ "Caused by mustBeBoolean handling" + ^ context ] ] +] diff --git a/Sindarin/DebugSession.extension.st b/Sindarin/DebugSession.extension.st index 7d932fe..31496ee 100644 --- a/Sindarin/DebugSession.extension.st +++ b/Sindarin/DebugSession.extension.st @@ -4,3 +4,28 @@ Extension { #name : #DebugSession } DebugSession >> asSindarinDebugSession [ ^ SindarinDebugSession new debugSession: self ] + +{ #category : #'*Sindarin' } +DebugSession >> stepToFirstInterestingBytecodeWithJumpIn: aProcess [ + "After a restart of a method activation step to the first + bytecode instruction that is of interest for the debugger. + + In this case step until a bytecode that causes a context switch, + as otherwise one will have to press may time step into without + seeing any visible results." + + "If we are are stepping into a quick method, + make sure that we step correctly over the first primitive bytecode" + | suspendedContext | + suspendedContext := aProcess suspendedContext. + (suspendedContext method isQuick and: [ suspendedContext pc == suspendedContext method initialPC ]) + ifTrue: [ ^ suspendedContext updatePCForQuickPrimitiveRestart ]. + + ^ aProcess stepToSendOrReturnOrJump +] + +{ #category : #'*Sindarin' } +DebugSession >> suspendedContext: aContext [ + + interruptedContext := aContext +] diff --git a/Sindarin/InstructionStream.extension.st b/Sindarin/InstructionStream.extension.st new file mode 100644 index 0000000..e819f3d --- /dev/null +++ b/Sindarin/InstructionStream.extension.st @@ -0,0 +1,38 @@ +Extension { #name : #InstructionStream } + +{ #category : #'*Sindarin' } +InstructionStream >> willJump [ + "Answer whether the next bytecode will jump." + + ^ self willJumpIfFalse or:[ self willJumpIfTrue or: [ self willJumpTo ] ] +] + +{ #category : #'*Sindarin' } +InstructionStream >> willJumpIfFalse [ + "Answer whether the next bytecode is a jump-if-false." + + ^ self method encoderClass isBranchIfFalseAt: pc in: self method +] + +{ #category : #'*Sindarin' } +InstructionStream >> willJumpIfTrue [ + "Answer whether the next bytecode is a jump-if-false." + + ^ self method encoderClass isBranchIfTrueAt: pc in: self method +] + +{ #category : #'*Sindarin' } +InstructionStream >> willJumpTo [ + "Answer whether the next bytecode is a jump-if-false." + + ^ self method encoderClass isJumpAt: pc in: self method +] + +{ #category : #'*Sindarin' } +InstructionStream >> willSendOrReturnOrStoreOrCreateBlock [ + + "Answer whether the next bytecode will be interesting for the debugger to stop." + + ^ self willSend or: [ + self willReturn or: [ self willStore or: [ self willCreateBlock ] ] ] +] diff --git a/Sindarin/NodeNotInASTError.class.st b/Sindarin/NodeNotInASTError.class.st new file mode 100644 index 0000000..e10cd45 --- /dev/null +++ b/Sindarin/NodeNotInASTError.class.st @@ -0,0 +1,8 @@ +" +I am signaled when we try to move the execution to a node that is not in the home context's method ast. +" +Class { + #name : #NodeNotInASTError, + #superclass : #Error, + #category : #'Sindarin-Exceptions' +} diff --git a/Sindarin/NotValidPcError.class.st b/Sindarin/NotValidPcError.class.st new file mode 100644 index 0000000..643a4f6 --- /dev/null +++ b/Sindarin/NotValidPcError.class.st @@ -0,0 +1,8 @@ +" +I am signaled when I try to modify the execution of a context to get to an invalid PC (lower than the method initalPC or greater than the method endPC) +" +Class { + #name : #NotValidPcError, + #superclass : #Error, + #category : #'Sindarin-Exceptions' +} diff --git a/Sindarin/OCBytecodeToASTCache.extension.st b/Sindarin/OCBytecodeToASTCache.extension.st new file mode 100644 index 0000000..534915d --- /dev/null +++ b/Sindarin/OCBytecodeToASTCache.extension.st @@ -0,0 +1,8 @@ +Extension { #name : #OCBytecodeToASTCache } + +{ #category : #'*Sindarin' } +OCBytecodeToASTCache >> firstRecursiveBcOffsetForStatementNode: aStatementNode [ + + ^ self methodOrBlockNode bcToASTCache bcToASTMap keys sorted detect: [ + :key | (self nodeForPC: key) statementNode == aStatementNode ] +] diff --git a/Sindarin/Process.extension.st b/Sindarin/Process.extension.st new file mode 100644 index 0000000..eb3b21f --- /dev/null +++ b/Sindarin/Process.extension.st @@ -0,0 +1,9 @@ +Extension { #name : #Process } + +{ #category : #'*Sindarin' } +Process >> stepToSendOrReturnOrJump [ + + ^Processor activeProcess + evaluate: [suspendedContext := suspendedContext stepToSendOrReturnOrJump] + onBehalfOf: self +] diff --git a/Sindarin/RBAssignmentNode.extension.st b/Sindarin/RBAssignmentNode.extension.st new file mode 100644 index 0000000..6878bcd --- /dev/null +++ b/Sindarin/RBAssignmentNode.extension.st @@ -0,0 +1,7 @@ +Extension { #name : #RBAssignmentNode } + +{ #category : #'*Sindarin' } +RBAssignmentNode >> skipWithDebugger: aSindarinDebugger [ + + aSindarinDebugger skipAssignmentNodeCompletely +] diff --git a/Sindarin/RBBlockNode.extension.st b/Sindarin/RBBlockNode.extension.st new file mode 100644 index 0000000..fdd3133 --- /dev/null +++ b/Sindarin/RBBlockNode.extension.st @@ -0,0 +1,47 @@ +Extension { #name : #RBBlockNode } + +{ #category : #'*Sindarin' } +RBBlockNode >> executedNodesAfter: aNode [ + + "Gives all nodes that are executed after aNode. Assuming that aNode is a recursive child, then all nodes executed after it are all nodes after it in allChildrenPostOrder" + + | nodesAfter indexOfNode | + nodesAfter := self allChildrenPostOrder. + indexOfNode := nodesAfter identityIndexOf: aNode. + nodesAfter := nodesAfter withIndexSelect: [ :value :index | + index > indexOfNode ]. + ^ nodesAfter +] + +{ #category : #'*Sindarin' } +RBBlockNode >> firstPCOfStatement: aStatementNode [ + + ^ self bcToASTCache firstRecursiveBcOffsetForStatementNode: aStatementNode +] + +{ #category : #'*Sindarin' } +RBBlockNode >> nextExecutedNodeAfter: aNode [ + + "Find first node that is after aNode that has an associated pc in method node all children (post-order)" + + | indexOfNextNode nodesAfter | + nodesAfter := self executedNodesAfter: aNode. + indexOfNextNode := nodesAfter findFirst: [ :each | + (self firstPcForNode: each) isNotNil ]. + ^ nodesAfter at: indexOfNextNode +] + +{ #category : #'*Sindarin' } +RBBlockNode >> parentOfIdenticalSubtree: subtree [ + + ^ self allChildren reversed + detect: [ :e | e == subtree ] + ifFound: [ :e | e parent ] + ifNone: [ nil ] +] + +{ #category : #'*Sindarin' } +RBBlockNode >> skipWithDebugger: aSindarinDebugger [ + + aSindarinDebugger skipBlockNode +] diff --git a/Sindarin/RBMessageNode.extension.st b/Sindarin/RBMessageNode.extension.st new file mode 100644 index 0000000..20711a9 --- /dev/null +++ b/Sindarin/RBMessageNode.extension.st @@ -0,0 +1,7 @@ +Extension { #name : #RBMessageNode } + +{ #category : #'*Sindarin' } +RBMessageNode >> skipWithDebugger: aSindarinDebugger [ + + aSindarinDebugger skipMessageNode +] diff --git a/Sindarin/RBMethodNode.extension.st b/Sindarin/RBMethodNode.extension.st new file mode 100644 index 0000000..789a1d9 --- /dev/null +++ b/Sindarin/RBMethodNode.extension.st @@ -0,0 +1,57 @@ +Extension { #name : #RBMethodNode } + +{ #category : #'*Sindarin' } +RBMethodNode >> executedNodesAfter: aNode [ + + "Gives all nodes that are executed after aNode. Assuming that aNode is a recursive child, then all nodes executed after it are all nodes after it in allChildrenPostOrder" + + | nodesAfter indexOfNode | + nodesAfter := self allChildrenPostOrder. + indexOfNode := nodesAfter identityIndexOf: aNode. + nodesAfter := nodesAfter withIndexSelect: [ :value :index | + index > indexOfNode ]. + ^ nodesAfter +] + +{ #category : #'*Sindarin' } +RBMethodNode >> firstPCOfStatement: aStatementNode [ + + ^ self bcToASTCache firstRecursiveBcOffsetForStatementNode: aStatementNode +] + +{ #category : #'*Sindarin' } +RBMethodNode >> nextExecutedNodeAfter: aNode [ + + "Find first node that is after aNode that has an associated pc in method node all children (post-order)" + + | indexOfNextNode nodesAfter | + nodesAfter := self executedNodesAfter: aNode. + indexOfNextNode := nodesAfter findFirst: [ :each | + (self firstPcForNode: each) isNotNil ]. + ^ nodesAfter at: indexOfNextNode +] + +{ #category : #'*Sindarin' } +RBMethodNode >> parentOfIdenticalSubtree: subtree [ + + ^ self allChildren reversed + detect: [ :e | e == subtree ] + ifFound: [ :e | e parent ] + ifNone: [ nil ] +] + +{ #category : #'*Sindarin' } +RBMethodNode >> statementNodeContaining: aNode [ + + | statementNode parentOfStatementNode | + statementNode := aNode. + parentOfStatementNode := self parentOfIdenticalSubtree: + statementNode. + parentOfStatementNode + ifNil: [ ^ NodeNotInASTError signal ] + ifNotNil: [ + [ parentOfStatementNode isSequence ] whileFalse: [ + statementNode := parentOfStatementNode. + parentOfStatementNode := parentOfStatementNode parent ] ]. + ^ statementNode +] diff --git a/Sindarin/RBProgramNode.extension.st b/Sindarin/RBProgramNode.extension.st new file mode 100644 index 0000000..2887116 --- /dev/null +++ b/Sindarin/RBProgramNode.extension.st @@ -0,0 +1,18 @@ +Extension { #name : #RBProgramNode } + +{ #category : #'*Sindarin' } +RBProgramNode >> allChildrenPostOrder [ + + | children | + children := OrderedCollection new. + self children do: [ :each | + each allChildrenPostOrder do: [ :child | children addLast: child ] ]. + children addLast: self. + ^ children +] + +{ #category : #'*Sindarin' } +RBProgramNode >> skipWithDebugger: aSindarinDebugger [ + + aSindarinDebugger step +] diff --git a/Sindarin/RBReturnNode.extension.st b/Sindarin/RBReturnNode.extension.st new file mode 100644 index 0000000..e9ffb01 --- /dev/null +++ b/Sindarin/RBReturnNode.extension.st @@ -0,0 +1,7 @@ +Extension { #name : #RBReturnNode } + +{ #category : #'*Sindarin' } +RBReturnNode >> skipWithDebugger: aSindarinDebugger [ + + aSindarinDebugger skipReturnNode +] diff --git a/Sindarin/SindarinDebugger.class.st b/Sindarin/SindarinDebugger.class.st index 3ccec11..44aade6 100644 --- a/Sindarin/SindarinDebugger.class.st +++ b/Sindarin/SindarinDebugger.class.st @@ -140,6 +140,13 @@ SindarinDebugger >> canStillExecute: aProgramNode [ ^ rightContext pc < lastPcForNode ] +{ #category : #cleaning } +SindarinDebugger >> cleanStack [ + + [ self context stackPtr > self context numTemps ] whileTrue: [ + self context pop ] +] + { #category : #stackAccess } SindarinDebugger >> context [ "Returns a reification of the current stack-frame." @@ -242,6 +249,12 @@ SindarinDebugger >> debugSession [ ^ sindarinSession debugSession ] +{ #category : #accessing } +SindarinDebugger >> firstPCOfStatement: aStatementNode [ + + ^ self methodNode firstPCOfStatement: aStatementNode +] + { #category : #private } SindarinDebugger >> hasSignalledUnhandledException [ "Returns true if the debugged execution has signalled an exception that has not been handled by any on:do: (i.e. the #defaultAction of the exception is about to be executed. This default action typically leads to opening a debugger on the process that signalled the exception)" @@ -291,6 +304,25 @@ SindarinDebugger >> isExecutionFinished [ ^ process isTerminated ] +{ #category : #'API - changes' } +SindarinDebugger >> jumpIntoBlock: aBlockNode toNode: targetNode [ + + "Moves to targetNode that must be in aBlockNode, which should be a recursive child" + + | blockClosure newContext firstPCForNode | + "To jump into a block, we change pc to the block creation pc and we step it to get the block closure and create a new context for it. Then, we call moveToNode: recursively to go to the correct pc in the new context (or to create even more contexts if we want to enter embedded blocks)" + firstPCForNode := self methodNode firstPcForNode: aBlockNode. + self pc: firstPCForNode. + self stepBytecode. + blockClosure := self context top. + newContext := blockClosure asContextWithSender: self context. + + "we need to change the suspended context and do the same in its debug session to see what we do in the debugger" + self currentProcess suspendedContext: newContext. + self debugSession suspendedContext: newContext. + ^ self moveToNode: targetNode +] + { #category : #stackAccessHelpers } SindarinDebugger >> message: aSelector [ "Returns whether the execution is about to send a message of selector @aSelector to any object" @@ -385,6 +417,34 @@ SindarinDebugger >> methodNode [ ^ self method ast ] +{ #category : #'API - changes' } +SindarinDebugger >> moveToNode: aNode [ + + "Allows to jump to the first bytecode offset associated to aNode, as long as aNode is in the same lexical context as the suspended context" + + | firstPCForNode | + firstPCForNode := self methodNode firstPcForNode: aNode. + + firstPCForNode ifNil: [ "If a node does not have any associated pc and if it is not a child in the method node then, aNode may be identical to the method node or its body, in which case, we move to the endPC. Otherwise, we check if it is a child in the home context's method node. If this is the case, this means we want to exit a block context. Otherwise, aNode is not a child in the home context's method node" + (self methodNode parentOfIdenticalSubtree: aNode) + ifNil: [ + (aNode == self methodNode or: [ aNode == self methodNode body ]) + ifTrue: [ firstPCForNode := self method endPC ] + ifFalse: [ + self context ~~ self context home + ifTrue: [ ^ self tryMoveToNodeInHomeContext: aNode ] + ifFalse: [ ^ NodeNotInASTError signal ] ] ] + ifNotNil: [ :parent | + | nextNode | + "If a node does not have any associated pc but this node is a child in the method node then, we go to the next node that will be executed (so in pre-order) and that has an associated pc in this context." + nextNode := self nextExecutedNodeAfter: aNode. + firstPCForNode := self methodNode firstPcForNode: nextNode. + nextNode isBlock ifTrue: [ "If the node after aNode is a block node, then this means we want to enter a block." + ^ self jumpIntoBlock: nextNode toNode: aNode ] ] ]. + + self pc: firstPCForNode +] + { #category : #'accessing - bytes' } SindarinDebugger >> nextBytecode [ @@ -392,6 +452,12 @@ SindarinDebugger >> nextBytecode [ each offset = self context pc ] ] +{ #category : #'API - changes' } +SindarinDebugger >> nextExecutedNodeAfter: aNode [ + + ^ self methodNode nextExecutedNodeAfter: aNode +] + { #category : #astAndAstMapping } SindarinDebugger >> node [ "Returns the AST node about to be executed by the top context of the execution" @@ -431,6 +497,31 @@ SindarinDebugger >> pc [ ^ self context pc ] +{ #category : #accessing } +SindarinDebugger >> pc: anInteger [ + + "Allows to move to the first PC associated to the node to which anInteger is associated. anInteger must be a valid pc in the suspended context" + + | nextNode methodNode firstPCOfStatementNode | + "If aimedPC is outside the context PCs range, then an error is signaled" + (anInteger < self method initialPC or: [ + anInteger > self method endPC ]) ifTrue: [ + ^ NotValidPcError signal ]. + methodNode := self methodNode. + nextNode := methodNode sourceNodeForPC: anInteger. + "If the aimed node is associated to the method node or its body, then we suppose that it is wanted and we'll get there directly" + (nextNode == methodNode or: [ nextNode == methodNode body ]) + ifTrue: [ firstPCOfStatementNode := anInteger ] + ifFalse: [ "If not, we skip to the wanted node, from the first (recursive) pc of the first statement node. We don't skip from the method node initial pc, otherwise we would create again the temp variables and lose their values." + firstPCOfStatementNode := self firstPCOfStatement: + methodNode statements first. + self cleanStack ]. + self context pc: firstPCOfStatementNode. + self debugSession stepToFirstInterestingBytecodeIn: + self debugSession interruptedProcess. + self skipUpToNode: nextNode +] + { #category : #'stepping - auto' } SindarinDebugger >> proceed [ "alias of #continue" @@ -556,21 +647,16 @@ SindarinDebugger >> sindarinSession: aSindarinDebugSession [ { #category : #'stepping - skip' } SindarinDebugger >> skip [ - - | nextBytecode | - "If it is a message send or assignment, skips the execution of the current instruction, and puts nil on the execution stack." - self node isAssignment ifTrue: [ ^ self skipAssignmentNodeCompletely ]. - self node isMessage ifTrue: [ ^ self skipMessageNode ]. - self node isMethod ifTrue: [ ^ self step ]. - self node isBlock ifTrue: [ self skipBlockNode ]. - nextBytecode := self currentBytecode detect: [ :each | - each offset = self pc ]. - (self node isReturn or: [ - nextBytecode bytes first between: 88 and: 94 ]) ifTrue: [ - ^ self skipReturnNode ]. - self node isSequence ifTrue: [ ^ self step ]. - self skipWith: nil + | instructionStream | + instructionStream := self context instructionStream. + + "We need to treat jumps before messages because if it is associated to a message node, it would pop the arguments of the message, that aren't on the stack if they are jumps" + instructionStream willJump ifTrue: [ ^ self skipJump ]. + "A return bytecode can be on any node so have to treat it here systematically" + instructionStream willReturn ifTrue: [ ^ self skipReturnNode ]. + + self node skipWithDebugger: self ] { #category : #'stepping - skip' } @@ -591,7 +677,7 @@ SindarinDebugger >> skipAssignmentNodeCompletely [ "Increase the pc to go over the assignment" self context pc: self context pc + currentBytecode bytes size. "Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)" - self debugSession stepToFirstInterestingBytecodeIn: + self debugSession stepToFirstInterestingBytecodeWithJumpIn: self debugSession interruptedProcess ] @@ -604,18 +690,37 @@ SindarinDebugger >> skipAssignmentNodeWith: replacementValue [ self step. "Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)" self debugSession - stepToFirstInterestingBytecodeIn: self debugSession interruptedProcess + stepToFirstInterestingBytecodeWithJumpIn: self debugSession interruptedProcess ] { #category : #'stepping - skip' } SindarinDebugger >> skipBlockNode [ | nextBytecode | - nextBytecode := self currentBytecode detect: [ :bytecode | bytecode offset = self pc ]. - + nextBytecode := self currentBytecode detect: [ :bytecode | + bytecode offset = self pc ]. + self context pc: self pc + nextBytecode bytes size. - - self context push: nil + + self context push: nil. + + self debugSession stepToFirstInterestingBytecodeWithJumpIn: + self debugSession interruptedProcess +] + +{ #category : #'stepping - skip' } +SindarinDebugger >> skipJump [ + + | instructionStream nextBytecode | + instructionStream := self context instructionStream. + "If the next bytecode is a jumpTrue: or a jumpFalse: bytecode, then it expects one argument on the stack. As we skip the jump bytecode, we pop it." + (instructionStream willJumpIfFalse or: [ + instructionStream willJumpIfTrue ]) ifTrue: [ self context pop ]. + nextBytecode := self currentBytecode detect: [ :each | + each offset = self pc ]. + self context pc: self context pc + nextBytecode bytes size. + self debugSession stepToFirstInterestingBytecodeWithJumpIn: + self debugSession interruptedProcess ] { #category : #'stepping - skip' } @@ -626,7 +731,7 @@ SindarinDebugger >> skipMessageNode [ "Increase the pc to go over the message send" self context pc: self context pc + self nextBytecode bytes size. "Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)" - self debugSession stepToFirstInterestingBytecodeIn: + self debugSession stepToFirstInterestingBytecodeWithJumpIn: self debugSession interruptedProcess ] @@ -641,7 +746,7 @@ SindarinDebugger >> skipMessageNodeWith: replacementValue [ "Increase the pc to go over the message send" self context pc: self context pc + self nextBytecode bytes size. "Execute bytecodes the debugger usually executes without stopping the execution (for example popping the return value of the just executed message send if it is not used afterwards)" - self debugSession stepToFirstInterestingBytecodeIn: + self debugSession stepToFirstInterestingBytecodeWithJumpIn: self debugSession interruptedProcess ] @@ -714,6 +819,23 @@ SindarinDebugger >> stack [ ^ self debugSession stack ] +{ #category : #API } +SindarinDebugger >> statementNodeContaining: aNode [ + + | method statementNode parentOfStatementNode | + method := self methodNode. + statementNode := aNode. + parentOfStatementNode := method parentOfIdenticalSubtree: + statementNode. + parentOfStatementNode + ifNil: [ ^ NodeNotInASTError signal ] + ifNotNil: [ + [ parentOfStatementNode isSequence ] whileFalse: [ + statementNode := parentOfStatementNode. + parentOfStatementNode := parentOfStatementNode parent ] ]. + ^ statementNode +] + { #category : #'stepping - steps' } SindarinDebugger >> step [ "Executes the next instruction. If the instruction is a message-send, step inside it." @@ -826,3 +948,20 @@ SindarinDebugger >> terminate [ SindarinDebugger >> topStack [ ^self context top ] + +{ #category : #'API - changes' } +SindarinDebugger >> tryMoveToNodeInHomeContext: aNode [ + + "Moves to node aNode if aNode is in the lexical context. Otherwise, the program state goes back to how it was before trying and signals an error as the node is not in AST" + + | oldContext | + oldContext := self context. + self currentProcess suspendedContext: oldContext home. + self debugSession suspendedContext: oldContext home. + [ self moveToNode: aNode ] + on: NodeNotInASTError + do: [ + self currentProcess suspendedContext: oldContext. + self debugSession suspendedContext: oldContext. + ^ NodeNotInASTError signal ] +]