Experimental solution for step through interpreting the full flow issue #16351

src/Commander-Activators-Shortcut/CmdShortcutActivation.class.st

@@ -82,6 +82,13 @@ CmdShortcutActivation class >> settingInputWidgetForNode: aShortcutSetting [
 	^ theme newRow: {catcherMorph}
 ]
 
+{ #category : 'accessing' }
+CmdShortcutActivation >> action [
+	"Answer a <CompiledMethod> defining the receiver's action"
+
+	^ self annotatedClass class lookupSelector: self declarationSelector
+]
+
 { #category : 'settings' }
 CmdShortcutActivation >> buildSettingNodeOn: aBuilder [
 	| nodeBuilder |
@@ -91,6 +98,15 @@ CmdShortcutActivation >> buildSettingNodeOn: aBuilder [
 	^nodeBuilder
 ]
 
+{ #category : 'printing' }
+CmdShortcutActivation >> description [
+	"Answer a <String> describing the receiver. We use the `action` method comments to retrieve the description"
+
+	^ self action comment
+		ifNil: [ String empty ]
+		ifNotNil: [ : comm | comm ]
+]
+
 { #category : 'accessing' }
 CmdShortcutActivation >> keyCombination [
 	^ keyCombination
@@ -101,6 +117,12 @@ CmdShortcutActivation >> keyCombination: anObject [
 	keyCombination := anObject
 ]
 
+{ #category : 'printing' }
+CmdShortcutActivation >> name [
+
+	^ self declarationSelector asString
+]
+
 { #category : 'printing' }
 CmdShortcutActivation >> printOn: aStream [
 	super printOn: aStream.
@@ -109,6 +131,26 @@ CmdShortcutActivation >> printOn: aStream [
 	aStream nextPut: $)
 ]
 
+{ #category : 'printing' }
+CmdShortcutActivation >> scope [
+	"The receiver's scope is the package name where is installed"
+
+	^ self annotatedClass packageName
+]
+
+{ #category : 'printing' }
+CmdShortcutActivation >> scopeName [
+
+	^ self scope asString
+]
+
+{ #category : 'printing' }
+CmdShortcutActivation >> shortcut [
+	"Answer a <String> representation of the receiver's key combination"
+
+	^ self keyCombination asString
+]
+
 { #category : 'command execution' }
 CmdShortcutActivation >> tryExecuteCommandInContext: aToolContext byEvents: anEventBuffer [
 

src/Debugger-Model-Tests/EnhancedStepThroughTest.class.st

@@ -0,0 +1,13 @@
+Class {
+	#name : 'EnhancedStepThroughTest',
+	#superclass : 'StepThroughTest',
+	#category : 'Debugger-Model-Tests-Core',
+	#package : 'Debugger-Model-Tests',
+	#tag : 'Core'
+}
+
+{ #category : 'utilities' }
+EnhancedStepThroughTest >> settingUpSessionAndProcessAndContextForBlock: aBlock [
+	super settingUpSessionAndProcessAndContextForBlock: aBlock.
+	session := process newEnhancedDebugSessionNamed: 'test session' startedAt: context
+]

src/Debugger-Model-Tests/EnhancedStepThroughWithHaltingBlockTest.class.st

@@ -0,0 +1,16 @@
+Class {
+	#name : 'EnhancedStepThroughWithHaltingBlockTest',
+	#superclass : 'StepThroughTest',
+	#category : 'Debugger-Model-Tests-Core',
+	#package : 'Debugger-Model-Tests',
+	#tag : 'Core'
+}
+
+{ #category : 'utilities' }
+EnhancedStepThroughWithHaltingBlockTest >> settingUpSessionAndProcessAndContextForBlock: aBlock [
+
+	super settingUpSessionAndProcessAndContextForBlock: aBlock.
+	session :=  EnhancedDebugSessionWithHaltingBlock named: 'test session' on: process startedAt: context
+
+
+]

src/Debugger-Model-Tests/StepThroughTest.class.st

@@ -1,11 +1,24 @@
 Class {
 	#name : 'StepThroughTest',
 	#superclass : 'DebuggerTest',
+	#instVars : [
+		'aBlock',
+		'failed'
+	],
 	#category : 'Debugger-Model-Tests-Core',
 	#package : 'Debugger-Model-Tests',
 	#tag : 'Core'
 }
 
+{ #category : 'helper' }
+StepThroughTest >> evalBlock: aBlockClosure afterLoop: remainingCount [
+
+	remainingCount = 1 ifTrue: [ ^ aBlockClosure value ].
+
+	^ self evalBlock: aBlockClosure afterLoop: remainingCount - 1. 
+
+]
+
 { #category : 'helper' }
 StepThroughTest >> evalBlockThenReturnOne: aBlock [
 	aBlock value.
@@ -38,6 +51,77 @@ StepThroughTest >> stepB3 [
 	^ 43
 ]
 
+{ #category : 'helper' }
+StepThroughTest >> stepC1 [
+	self evalBlock: [ self stepC2 ] afterLoop: 100
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepC2 [
+
+	^ 5
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepD1 [
+
+	aBlock := [ 2 + 3 ].
+
+	self stepD2
+
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepD2 [
+
+	aBlock value
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepE1 [
+
+	| tmpBlock |
+	tmpBlock := [ 2 - 3 ].
+
+	self evalBlockThenReturnOne: tmpBlock	
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepF1 [
+
+	| tmpBlock |
+	tmpBlock := [ 2 - 3 ].
+
+	tmpBlock value
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepG1 [
+
+	| sem |
+
+	sem := Semaphore new.
+
+	self stepG2: [ 1 + 3 ] sem: sem.
+
+]
+
+{ #category : 'helper' }
+StepThroughTest >> stepG2: aTmp sem: sem [
+
+	[
+	sem wait.
+	[
+	aTmp value.
+	failed := false ] on: Exception do: [ failed := true ] ] forkAt:
+		Processor activePriority + 1.
+
+	sem signal.
+
+	[ failed isNil ] whileTrue: [ Processor yield ].
+
+]
+
 { #category : 'tests' }
 StepThroughTest >> testStepThrough [
 	"In a context c, define a block b, send a message to another method to get b evaluated.
@@ -48,15 +132,15 @@ StepThroughTest >> testStepThrough [
 	session stepInto.
 	"Reached node 'self evalBlockThenReturnOne: [self stepA2]' of method stepA1"
 	"Checking that the execution is indeed at this node"
-	self assert: (session interruptedContext method) equals: (self class>>#stepA1).
-	node := self class>>#stepA1 sourceNodeForPC: session interruptedContext pc.
+	self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepA1).
+	node := (self class lookupSelector: #stepA1) sourceNodeForPC: session interruptedContext pc.
 	self assert: node isMessage.
 	self assert: node receiver isSelfVariable.
 	self assert: node selector equals: #evalBlockThenReturnOne:.
 	session stepThrough.
 
 	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
-	expectedMethod := (self class >> #stepA1) literalAt: 1 .
+	expectedMethod := (self class lookupSelector: #stepA1) literalAt: 1 .
 
 	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
 	self assert: (session interruptedContext method) equals: expectedMethod.
@@ -72,34 +156,160 @@ StepThroughTest >> testStepThroughDoesTheSameThingAsStepOverWhenNoBlockIsInvolve
 	| node |
 
 	self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ].
-	[session interruptedContext method == (self class>>#stepB1)]
+	[session interruptedContext method == (self class lookupSelector: #stepB1)]
 		whileFalse: [ session stepInto ].
 
 	"Reached node 'self stepB2' of method stepB1"
-	self assert: session interruptedContext method equals: self class>>#stepB1.
+	self assert: session interruptedContext method equals: (self class lookupSelector:#stepB1).
 	session stepOver.
-	self assert: (session interruptedContext method) equals: (self class>>#stepB1).
+	self assert: (session interruptedContext method) equals: (self class lookupSelector:#stepB1).
 	"Checking that after the step over, we reached the node 'self stepB3' of method stepB1"
-	node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc.
+	node := (self class lookupSelector:#stepB1) sourceNodeForPC: session interruptedContext pc.
 	self assert: node isMessage.
 	self assert: node receiver isSelfVariable.
 	self assert: node selector equals: #stepB3.
 
 	"Set up the debugged execution again"
 	self settingUpSessionAndProcessAndContextForBlock: [ self stepB1 ].
-	[session interruptedContext method == (self class>>#stepB1)]
+	[session interruptedContext method == (self class lookupSelector:#stepB1)]
 		whileFalse: [ session stepInto ].
 
 	"Reached node 'self stepB2' of method stepB1"
-	self assert: session interruptedContext method equals: self class>>#stepB1.
+	self assert: session interruptedContext method equals: (self class lookupSelector:#stepB1).
 	session stepThrough.
 	"Checking that after the step through, we reached the node 'self stepB3' of method stepB1 (the same node that was reached with the step over"
-	node := self class>>#stepB1 sourceNodeForPC: session interruptedContext pc.
+	node := (self class lookupSelector:#stepB1) sourceNodeForPC: session interruptedContext pc.
 	self assert: node isMessage.
 	self assert: node receiver isSelfVariable.
 	self assert: node selector equals: #stepB3
 ]
 
+{ #category : 'tests' }
+StepThroughTest >> testStepThroughInABlockInAInstanceVariable [
+	"In a context c, define a block b, send a message to another method to get b evaluated.
+	Testing that a step through on this message send moves the execution to the point where the block b is about to be evaluated."
+	| node expectedMethod |
+
+	self settingUpSessionAndProcessAndContextForBlock: [ self stepD1 ].
+
+	session stepInto.
+	session stepInto.
+	session stepInto.
+
+	"Reached node 'self evalBlock: [ self stepC2 ] afterLoop: 10' of method stepC1"
+	"Checking that the execution is indeed at this node"
+	self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepD1).
+	node := (self class lookupSelector:#stepD1) sourceNodeForPC: session interruptedContext pc.
+
+	session stepThrough.
+
+	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
+	expectedMethod := (self class lookupSelector: #stepD1) literalAt: 1 .
+
+	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
+	self assert: (session interruptedContext method) equals: expectedMethod.
+	node := expectedMethod sourceNodeForPC: session interruptedContext pc.
+	self assert: node isMessage.
+	self assert: node receiver value equals: 2.
+	self assert: node selector equals: #+
+]
+
+{ #category : 'tests' }
+StepThroughTest >> testStepThroughInABlockInATemporary [
+
+	| node expectedMethod |
+
+	self settingUpSessionAndProcessAndContextForBlock: [ self stepE1 ].
+
+	session stepInto.
+	session stepInto.
+	session stepInto.
+
+	self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepE1).
+	node := (self class lookupSelector:#stepE1) sourceNodeForPC: session interruptedContext pc.
+
+	session stepThrough.
+
+	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
+	expectedMethod := (self class lookupSelector: #stepE1) literalAt: 1 .
+
+	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
+	self assert: (session interruptedContext method) equals: expectedMethod.
+	node := expectedMethod sourceNodeForPC: session interruptedContext pc.
+	self assert: node isMessage.
+	self assert: node receiver value equals: 2.
+	self assert: node selector equals: #-
+]
+
+{ #category : 'tests' }
+StepThroughTest >> testStepThroughInABlockInATemporaryDirectly [
+
+	| node expectedMethod |
+
+	self settingUpSessionAndProcessAndContextForBlock: [ self stepF1 ].
+
+	session stepInto.
+	session stepInto.
+	session stepInto.
+
+	self assert: (session interruptedContext method) equals: (self class lookupSelector: #stepF1).
+	node := (self class lookupSelector:#stepF1) sourceNodeForPC: session interruptedContext pc.
+
+	session stepThrough.
+
+	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
+	expectedMethod := (self class lookupSelector: #stepF1) literalAt: 1 .
+
+	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
+	self assert: (session interruptedContext method) equals: expectedMethod.
+	node := expectedMethod sourceNodeForPC: session interruptedContext pc.
+	self assert: node isMessage.
+	self assert: node receiver value equals: 2.
+	self assert: node selector equals: #-
+]
+
+{ #category : 'tests' }
+StepThroughTest >> testStepThroughInOtherProcess [
+
+	self settingUpSessionAndProcessAndContextForBlock: [ self stepG1 ].
+
+	session stepInto.
+
+	session stepThrough.
+	session stepThrough.
+	session stepThrough.
+	session stepThrough.
+
+	self deny: failed.
+]
+
+{ #category : 'tests' }
+StepThroughTest >> testStepThroughLonger [
+	"In a context c, define a block b, send a message to another method to get b evaluated.
+	Testing that a step through on this message send moves the execution to the point where the block b is about to be evaluated."
+	| node expectedMethod |
+
+	self settingUpSessionAndProcessAndContextForBlock: [ self stepC1 ].
+	session stepInto.
+	session stepInto.
+	"Reached node 'self evalBlock: [ self stepC2 ] afterLoop: 10' of method stepC1"
+	"Checking that the execution is indeed at this node"
+	self assert: (session interruptedContext method) equals: (self class lookupSelector:#stepC1).
+	node := (self class lookupSelector:#stepC1) sourceNodeForPC: session interruptedContext pc.
+
+	session stepThrough.
+
+	"With fullblocks the method of the suspended context is a compiledBlock, not the method having it"
+	expectedMethod := (self class lookupSelector: #stepC1) literalAt: 1 .
+
+	"Checking that after the step through, the execution is at the 'self stepA2' node of the stepA1 method"
+	self assert: (session interruptedContext method) equals: expectedMethod.
+	node := expectedMethod sourceNodeForPC: session interruptedContext pc.
+	self assert: node isMessage.
+	self assert: node receiver isSelfVariable.
+	self assert: node selector equals: #stepC2
+]
+
 { #category : 'tests' }
 StepThroughTest >> testStepThroughUntilTermination [
 	"Stepping over a message node brings the execution to the next node in the same method."