diff --git a/src/Sindarin-Scripts/SindarinDebugger.extension.st b/src/Sindarin-Scripts/SindarinDebugger.extension.st new file mode 100644 index 0000000..de4a9bc --- /dev/null +++ b/src/Sindarin-Scripts/SindarinDebugger.extension.st @@ -0,0 +1,7 @@ +Extension { #name : #SindarinDebugger } + +{ #category : #'*Sindarin-Scripts' } +SindarinDebugger >> run: aSindarinScript [ + + aSindarinScript executeWith: self +] diff --git a/src/Sindarin-Scripts/TSindarin.extension.st b/src/Sindarin-Scripts/TSindarin.extension.st new file mode 100644 index 0000000..e1a088c --- /dev/null +++ b/src/Sindarin-Scripts/TSindarin.extension.st @@ -0,0 +1,21 @@ +Extension { #name : #TSindarin } + +{ #category : #'*Sindarin-Scripts' } +TSindarin classSide >> debugSessionWithScript: aDebugSession [ + + | debugger exception sindarinPointCutExceptionClass | + debugger := self debugSession: aDebugSession. + + exception := aDebugSession exception. + sindarinPointCutExceptionClass := Smalltalk at: #SindarinPointcutException ifAbsent:[nil]. + exception class == sindarinPointCutExceptionClass ifFalse: [ + aDebugSession resume; clear. + ^ self ]. + + "Stepping to return to the context requesting the execution of a Sindarin script" + debugger step. + debugger step. + exception script executeWith: debugger. + aDebugSession resume; clear; terminate + +] diff --git a/src/Sindarin-Tests/SindarinDebuggerTest.class.st b/src/Sindarin-Tests/SindarinDebuggerTest.class.st index 2813bc5..4dd99e5 100644 --- a/src/Sindarin-Tests/SindarinDebuggerTest.class.st +++ b/src/Sindarin-Tests/SindarinDebuggerTest.class.st @@ -487,6 +487,18 @@ SindarinDebuggerTest >> testIsAboutToInstantiateClass [ ] +{ #category : #tests } +SindarinDebuggerTest >> testIsAssignment [ + + | scdbg | + scdbg := SindarinDebugger debug: [ self methodWithOneAssignment ]. + self deny: scdbg isAssignment. + scdbg step. + self assert: scdbg isAssignment. + scdbg step. + self deny: scdbg isAssignment +] + { #category : #tests } SindarinDebuggerTest >> testIsExecutionFinished [ @@ -499,6 +511,26 @@ SindarinDebuggerTest >> testIsExecutionFinished [ self assert: scdbg currentProcess isTerminated ] +{ #category : #tests } +SindarinDebuggerTest >> testIsMessageSend [ + + | scdbg | + scdbg := SindarinDebugger debug: [ self methodWithOneAssignment ]. + self assert: scdbg isMessageSend. + scdbg step. + self deny: scdbg isMessageSend. + scdbg step. + self assert: scdbg isMessageSend +] + +{ #category : #tests } +SindarinDebuggerTest >> testMessage [ + + | scdbg | + scdbg := SindarinDebugger debug: [ self methodWithOneAssignment ]. + self assert: (scdbg message: #methodWithOneAssignment) +] + { #category : #tests } SindarinDebuggerTest >> testMessageArguments [ | scdbg | diff --git a/src/Sindarin/ContextNotOnStack.class.st b/src/Sindarin/ContextNotOnStack.class.st deleted file mode 100644 index 71cc1ac..0000000 --- a/src/Sindarin/ContextNotOnStack.class.st +++ /dev/null @@ -1,5 +0,0 @@ -Class { - #name : #ContextNotOnStack, - #superclass : #Error, - #category : #'Sindarin-Exceptions' -} diff --git a/src/Sindarin/SindarinDebugger.class.st b/src/Sindarin/SindarinDebugger.class.st index fc78162..249cf2e 100644 --- a/src/Sindarin/SindarinDebugger.class.st +++ b/src/Sindarin/SindarinDebugger.class.st @@ -25,8 +25,8 @@ Class { { #category : #stackAccessHelpers } SindarinDebugger >> assignmentValue [ "Returns the value about to be assigned, if the current node is an assignment node. Otherwise, returns nil" - - self node isAssignment ifFalse: [ + self flag: 'Why there is no error raised here, while for the case of message sends there is an error?'. + self isAssignment ifFalse: [ ^ nil "Error signal: 'Not about to perform a assignment'" ]. ^ self context at: self currentContextStackSize ] @@ -34,8 +34,8 @@ SindarinDebugger >> assignmentValue [ { #category : #stackAccessHelpers } SindarinDebugger >> assignmentVariableName [ "Returns the variable name about to be assigned to, if the current node is an assignment node. Otherwise, returns nil" - - self node isAssignment ifFalse: [ + self flag: 'Why there is no error raised in the case of assignemnts, while there is one for message sends?'. + self isAssignment ifFalse: [ ^ nil "Error signal: 'Not about to perform a assignment'" ]. ^ self node variable name ] @@ -70,14 +70,13 @@ SindarinDebugger >> contextIsAboutToSignalException: aContext [ | node | node := self node. - node isMessage ifFalse: [ ^ false ]. + self isMessageSend ifFalse: [ ^ false ]. (#( #signal #signalIn: ) includes: node selector) ifFalse: [ ^ false ]. aContext basicSize >= 1 ifFalse: [ ^ false ]. (Exception allSubclasses includes: (aContext at: aContext basicSize)) ifTrue: [ ^ true ]. "#signal sent to a subclass of Exception" - (Exception allSubclasses includes: - (aContext at: aContext basicSize) class) ifTrue: [ ^ true ]. "#signal sent to an instance of a subclass of Exception" - ^ false + ^(Exception allSubclasses includes: (aContext at: aContext basicSize) class) "#signal sent to an instance of a subclass of Exception" + ] { #category : #'stepping - auto' } @@ -108,7 +107,7 @@ SindarinDebugger >> hasSignalledUnhandledException [ SindarinDebugger >> isAboutToInstantiateClass [ | methodAboutToExecute | - self node isMessage ifFalse: [ ^ false ]. + self isMessageSend ifFalse: [ ^ false ]. methodAboutToExecute := self receiver class lookupSelector: self node selector. ^ methodAboutToExecute notNil and: [ @@ -144,9 +143,7 @@ SindarinDebugger >> jumpIntoBlock: aBlockNode toNode: targetNode [ SindarinDebugger >> message: aSelector [ "Returns whether the execution is about to send a message of selector @aSelector to any object" - [ ^ self messageSelector = aSelector ] - on: Error - do: [ ^ false ] + ^ self isMessageSend and: [ self messageSelector = aSelector ] ] { #category : #stackAccessHelpers } @@ -162,13 +159,9 @@ SindarinDebugger >> message: aSelector toInstanceOf: aClass [ | node | node := self node. - node isMessage - ifFalse: [ ^ false ]. - node selector = aSelector - ifFalse: [ ^ false ]. - (self messageReceiver isKindOf: aClass) - ifFalse: [ ^ false ]. - ^ true + self isMessageSend ifFalse: [ ^ false ]. + node selector = aSelector ifFalse: [ ^ false ]. + ^ self messageReceiver isKindOf: aClass ] { #category : #stackAccessHelpers } @@ -176,7 +169,7 @@ SindarinDebugger >> messageArguments [ "Returns the arguments of the message about to be sent, if the current node is a message node." | argumentNumber arguments i | - self node isMessage ifFalse: [ + self isMessageSend ifFalse: [ Error signal: 'Not about to send a message' ]. argumentNumber := self node arguments size. arguments := OrderedCollection new. @@ -192,7 +185,7 @@ SindarinDebugger >> messageArguments [ SindarinDebugger >> messageReceiver [ "Returns the receiver of the message about to be sent, if the current node is a message node." - self node isMessage + self isMessageSend ifFalse: [ Error signal: 'Not about to send a message' ]. ^ self context at: self currentContextStackSize - self node arguments size @@ -202,7 +195,7 @@ SindarinDebugger >> messageReceiver [ SindarinDebugger >> messageSelector [ "Returns the selector of the message about to be sent, if the current node is a message node." - self node isMessage + self isMessageSend ifFalse: [ Error signal: 'Not about to send a message' ]. ^ self node selector ] @@ -280,19 +273,13 @@ SindarinDebugger >> proceed [ ^ self continue ] -{ #category : #scripts } -SindarinDebugger >> run: aSindarinScript [ - - aSindarinScript executeWith: self -] - { #category : #asserting } SindarinDebugger >> shouldStepIntoInMethod: aRBMethodNode [ "used by #stpeToReturn to know if it should stepInto or stepOver. It should stepInto to get to non-local returns" | messageNode childrenOfMessageNode | messageNode := self node. - messageNode isMessage ifFalse: [ ^ false ]. + self isMessageSend ifFalse: [ ^ false ]. childrenOfMessageNode := messageNode children. childrenOfMessageNode := childrenOfMessageNode select: [ :child | @@ -488,13 +475,12 @@ SindarinDebugger >> skipWith: replacementValue [ "If the current node is a message send or assignment" - (self node isMessage not - and: [ self node isAssignment not ]) - ifTrue: [ ^ self ]. - self node isMessage - ifTrue: [ ^ self skipMessageNodeWith: replacementValue ]. - self node isAssignment - ifTrue: [ ^ self skipAssignmentNodeWith: replacementValue ] + (self isMessageSend not and: [ self isAssignment not ]) ifTrue: [ + ^ self ]. + self node isMessage ifTrue: [ + ^ self skipMessageNodeWith: replacementValue ]. + self node isAssignment ifTrue: [ + ^ self skipAssignmentNodeWith: replacementValue ] ] { #category : #'ast manipulation' } diff --git a/src/Sindarin/SindarinUILessDebugger.class.st b/src/Sindarin/SindarinUILessDebugger.class.st deleted file mode 100644 index e356e73..0000000 --- a/src/Sindarin/SindarinUILessDebugger.class.st +++ /dev/null @@ -1,22 +0,0 @@ -Class { - #name : #SindarinUILessDebugger, - #superclass : #Object, - #category : #'Sindarin-Base' -} - -{ #category : #'debugger declaration' } -SindarinUILessDebugger class >> openOn: aDebugSession withFullView: aBool andNotification: aString [ - "This method will be called to open this debugger on a given debug session (i.e. execution to debug). If this debugger wants to keep the debug session (and its process) alive (for example because it is a graphical debugger that would break if the debug session is terminated while its window is open), it should call #keepAlive: on @aDebugSession, passing itself as argument. - The contract is that if a debugger calls #keepAlive:, it should also call #stopKeepingAlive: on @aDebugSession when it closes (passing itself as argument again). - The debug session will automatically not be kept alive by this debugger anymore if this debugger gets garbage collected (and DebugSession will only hold a weak reference to this debugger, so it will not prevent its garbage collection)" - aDebugSession keepAlive: self. - Smalltalk tools inspector openOn: (SindarinDebugger attachTo: aDebugSession). - "BAD: this debugger should call #stopKeepingAlive: on aDebugSession when it is close. Unfortunately, since it's just an inspector, I do not know how to make something happen when the inspector window closes" -] - -{ #category : #'debugger declaration' } -SindarinUILessDebugger class >> rankDebugSession: aDebugSession [ - "Returns an integer representing how much this debugger is suitable to debug @aDebugSession. The higher the integer returned, the more suitable this debugger is. Signal the DebugSessionCannotBeOpenedByThisDebugger exception if this debugger absolutely cannot debug @aDebugSession (for example if this debugger can only handle debug sessions from test executions, and @aDebugSession does not come from a test execution)" - - ^ 25 -] diff --git a/src/Sindarin/TSindarin.trait.st b/src/Sindarin/TSindarin.trait.st index 7ade0cb..a834351 100644 --- a/src/Sindarin/TSindarin.trait.st +++ b/src/Sindarin/TSindarin.trait.st @@ -35,24 +35,10 @@ TSindarin classSide >> debug: aBlock [ { #category : #'instance creation' } TSindarin classSide >> debugSession: aDebugSession [ - | debugger exception sindarinPointCutExceptionClass | - debugger := self attachTo: aDebugSession. - - exception := aDebugSession exception. - sindarinPointCutExceptionClass := Smalltalk at: #SindarinPointcutException ifAbsent:[nil]. - exception class == sindarinPointCutExceptionClass ifFalse: [ - aDebugSession resume; clear. - ^ self ]. - - "Stepping to return to the context requesting the execution of a Sindarin script" - debugger step. - debugger step. - exception script executeWith: debugger. - aDebugSession resume; clear; terminate - + ^ self attachTo: aDebugSession ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - helpers' } TSindarin >> arguments [ "Returns the arguments of the current stack-frame." @@ -93,7 +79,7 @@ TSindarin >> cleanStack [ self context pop ] ] -{ #category : #stackAccess } +{ #category : #'stack access' } TSindarin >> context [ "Returns a reification of the current stack-frame." @@ -151,14 +137,24 @@ TSindarin >> instructionStream [ ^ self context instructionStream ] -{ #category : #stackAccess } +{ #category : #'stack access - testing' } +TSindarin >> isAssignment [ + ^self node isAssignment +] + +{ #category : #'stack access' } TSindarin >> isExecutionFinished [ "Returns whether the debugged execution is finished" ^ process isTerminated ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - testing' } +TSindarin >> isMessageSend [ + ^self node isMessage +] + +{ #category : #'stack access - helpers' } TSindarin >> method [ "Returns the method of the current stack-frame." @@ -207,13 +203,13 @@ TSindarin >> pc [ ^ self context pc ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - helpers' } TSindarin >> readVariableNamed: aSymbol [ ^ self context readVariableNamed: aSymbol ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - helpers' } TSindarin >> receiver [ "Returns the receiver of the current stack-frame." @@ -234,7 +230,7 @@ TSindarin >> resume [ sindarinSession resumeAndClear ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - helpers' } TSindarin >> selector [ "Returns the selector of the current stack-frame." @@ -255,7 +251,7 @@ TSindarin >> skipPcToNextBytecode [ self context pc: self context pc + currentBytecode bytes size ] -{ #category : #stackAccess } +{ #category : #'stack access' } TSindarin >> stack [ "Returns a list of context objects representing the current call stack." @@ -274,7 +270,7 @@ TSindarin >> terminate [ sindarinSession terminate ] -{ #category : #stackAccessHelpers } +{ #category : #'stack access - helpers' } TSindarin >> topStack [ ^ self context top