[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] DebugTools package
|
From: |
Paolo Bonzini |
|
Subject: |
[Help-smalltalk] [PATCH] DebugTools package |
|
Date: |
Sat, 21 Jul 2007 11:32:21 +0200 |
|
User-agent: |
Thunderbird 2.0.0.5 (Macintosh/20070716) |
This provides a class to control an inferior process. It also includes
a fast implementation of the "next" and "finish" using continuations
instead of single-stepping.
Paolo
2007-07-16 Paolo Bonzini <address@hidden>
* examples/MiniDebugger.st: Use DebugTools.
* kernel/ContextPart.st: Add stub methods for #currentLine and
#debugger.
* kernel/ExcHandling.st: Use #stopInferior: if the process is
already being debugged.
* kernel/ProcSched.st: Add #activeDebugger.
* kernel/Process.st: Add #debugger.
* packages/browser/Debugger.st: Use DebugTools.
* packages/browser/Notifier.st: Use DebugTools.
* packages/browser/Load.st: Delimit namespaces with periods.
* packages/debug/DebugTools.st: New.
* packages/debug/debugtests.st: New.
* looking for address@hidden/smalltalk--devo--2.2--patch-471 to compare with
* comparing to address@hidden/smalltalk--devo--2.2--patch-471
A/ packages/debug
A packages/debug/ChangeLog
A packages/debug/DebugTools.st
A packages/debug/debugtests.st
A packages/debug/package.xml
M tests/testsuite.at
M tests/testsuite
M packages/browser/package.xml
M configure.ac
M examples/MiniDebugger.st
M ChangeLog
M packages/browser/ChangeLog
M packages/browser/Debugger.st
M packages/browser/Load.st
M packages/browser/Notifier.st
M NEWS
M TODO
M kernel/ContextPart.st
M kernel/ExcHandling.st
M kernel/ProcSched.st
M kernel/Process.st
* modified files
--- orig/NEWS
+++ mod/NEWS
@@ -81,6 +81,10 @@ o Added #from: to Collection, which co
returns a string and is the same as using #, repeatedly, but is more
efficient.
+o A new package DebugTools provides a generic Debugger class that can
+ be used to control an inferior Smalltalk process. It is used by the
+ textual MiniDebugger.
+
o Continuations and generators have moved to the base image. More complex
examples of continuations still reside in the Continuations package.
--- orig/configure.ac
+++ mod/configure.ac
@@ -247,6 +247,7 @@ GST_PACKAGE([BloxTK], [blox/tk],
[Makefile], [blox-tk.la])
GST_PACKAGE([Browser], [browser])
GST_PACKAGE([Continuations], [continuations])
+GST_PACKAGE([DebugTools], [debug])
GST_PACKAGE([DB], [db])
GST_PACKAGE([GDBM], [gdbm],
[AC_CHECK_HEADER([gdbm.h])],
--- orig/examples/MiniDebugger.st
+++ mod/examples/MiniDebugger.st
@@ -1,6 +1,6 @@
"======================================================================
|
-| Minimal inspector and debugger
+| Minimal inspector and debugger using DebugTools
|
|
======================================================================"
@@ -8,7 +8,7 @@
"======================================================================
|
-| Copyright 2002, 2006 Free Software Foundation, Inc.
+| Copyright 2002, 2006, 2007 Free Software Foundation, Inc.
| Written by Paolo Bonzini.
|
| This file is part of GNU Smalltalk.
@@ -28,6 +28,7 @@
|
======================================================================"
+PackageLoader fileInPackage: #DebugTools!
Object subclass: #MiniTool
instanceVariableNames: 'commandArg command'
@@ -44,8 +45,7 @@ MiniTool subclass: #MiniInspector
!
MiniTool subclass: #MiniDebugger
- instanceVariableNames: 'process activeContext depth stepSemaphore
- methodSourceCodeCache methodLineMapCache'
+ instanceVariableNames: 'debugger activeContext depth
methodSourceCodeCache'
classVariableNames: ''
poolDictionaries: ''
category: 'System-Debugging-Support'
@@ -244,112 +244,78 @@ debuggingPriority
!MiniDebugger class methodsFor: 'instance creation'!
-openOn: process message: aString
- [
- Processor activeProcess name: 'MiniDebugger'.
- [ process isSuspended ] whileFalse: [ Processor yield ].
- aString printNl.
- self new initializeFor: process; commandLoop
- ] fork.
- process suspend.
+open: aString
+ [ :debugger || continuation arg |
+ Processor activeProcess name: 'Debugger'.
+ arg := Continuation currentDo: [ :cc |
+ continuation := cc.
+ aString ].
+ arg printNl.
+ [ self new debugger: debugger; commandLoop ]
+ on: SystemExceptions.DebuggerReentered
+ do: [ :ex | continuation value: ex messageText ]
+ ] forkDebugger
! !
-
-!MiniDebugger methodsFor: 'stepping commands'!
+!MiniDebugger methodsFor: 'commands'!
-up
- activeContext parentContext isNil ifTrue: [ ^self ].
- activeContext := activeContext parentContext.
- depth := depth + 1.
+debugger: aDebugger
+ debugger := aDebugger.
!
-down
- depth > 0 ifFalse: [ ^self ].
- depth := depth - 1.
- activeContext := process suspendedContext.
- depth timesRepeat: [ activeContext := activeContext parentContext ]
-!
+commandLoop
-stepBytecode
- process singleStepWaitingOn: stepSemaphore.
- process suspend.
-!
+ "Show meaningful source code to the user."
+ [ debugger suspendedContext isInternalExceptionHandlingContext ]
+ whileTrue: [ debugger slowFinish ].
-step
- | context line |
- context := process suspendedContext.
- line := self currentLine.
+ depth := 0.
+ activeContext := debugger suspendedContext.
+ debugger suspendedContext backtrace.
+ self printCurrentLine.
[
- self stepBytecode.
- activeContext := process suspendedContext.
- activeContext == context and: [ line = self currentLine ]
+ self getCommand.
+ debugger isActive
] whileTrue.
- depth := 0.
+ Processor activeProcess suspend
!
-next
- | context |
- context := process suspendedContext.
- [
- self step.
- activeContext notNil and: [ activeContext parentContext == context ]
- ] whileTrue: [
- self finish: activeContext
- ]
-!
-finish: aContext
- | context |
- [
- context := process suspendedContext.
- [
- self stepBytecode.
- process suspendedContext == context
- ] whileTrue.
-
- activeContext := process suspendedContext.
- activeContext notNil "no context? exit"
- and: [ activeContext parentContext == context "a send? go on"
- or: [ (self depthOf: aContext) notNil ]] "aContext still in the
chain? go on"
- ] whileTrue
-!
+!MiniDebugger methodsFor: 'commands'!
+
+step
+ debugger step.
+ self resetContext!
+
+next
+ debugger next.
+ self resetContext!
finish
- self finish: activeContext
-!
+ debugger finish: activeContext.
+ self resetContext!
continue
- | proc |
- proc := Processor activeProcess.
- [ proc terminate. process resume ] forkAt: Processor unpreemptedPriority.
-
- "Suspend just in case we get here."
- proc suspend
-! !
+ debugger continue!
-
-!MiniDebugger methodsFor: 'source code'!
+resetContext
+ activeContext := debugger suspendedContext.
+ depth := 0!
-currentMethodSource
- activeContext isNil ifTrue: [ ^#() ].
- ^methodSourceCodeCache at: activeContext method ifAbsentPut: [
- self linesOf: activeContext method methodSourceString
- ]
+up
+ activeContext parentContext isNil ifTrue: [ ^self ].
+ activeContext := activeContext parentContext.
+ depth := depth + 1.
!
-currentLine
- | lineMap |
- activeContext isNil ifTrue: [ ^self ].
- lineMap := methodLineMapCache at: activeContext method ifAbsentPut: [
- activeContext method sourceCodeMap
- ].
- ^lineMap at: activeContext ip + 1 ifAbsent: [ activeContext inspect. 1 ]
-!
+down
+ depth > 0 ifFalse: [ ^self ].
+ depth := depth - 1.
+ activeContext := debugger suspendedContext.
+ depth timesRepeat: [ activeContext := activeContext parentContext ]
+! !
-linesOf: aString
- aString isNil ifTrue: [ ^nil ].
- ^aString readStream lines contents
-!
+!MiniDebugger methodsFor: 'printing'!
printCurrentMethod
| source |
@@ -366,9 +332,10 @@ printCurrentMethod
printCurrentLine
| line source |
+ activeContext isNil ifTrue: [ ^self ].
source := self currentMethodSource.
source isNil ifTrue: [ ^self ].
- line := self currentLine.
+ line := Debugger currentLineIn: activeContext.
line = 0 ifTrue: [ ^self ].
self rightJustify: line.
@@ -409,7 +376,11 @@ doProcessCommand
| id proc |
('TSKb' includes: command) ifFalse: [ ^false ].
- proc := process.
+ (commandArg isEmpty and: [ command == $b ]) ifTrue: [
+ activeContext backtrace.
+ ^true ].
+
+ proc := debugger process.
commandArg notEmpty ifTrue: [
id := Number readFrom: commandArg onError: nil.
@@ -421,12 +392,12 @@ doProcessCommand
proc suspendedContext isNil
ifTrue: [ 'process was terminated' displayNl. ^true ].
- (command == $b) ifTrue: [ self backtraceOf: proc ].
+ (command == $b) ifTrue: [ proc context backtrace ].
(command == $S) ifTrue: [ proc suspend ].
(command == $K) ifTrue: [ proc primTerminate ].
(command == $T) ifTrue: [
proc terminate.
- proc == process ifTrue: [ self continue ]
+ proc == debugger process ifTrue: [ self continue ]
].
^true
!
@@ -455,14 +426,6 @@ doCommand
^true
!
-commandLoop
- [
- self getCommand.
- process isTerminated
- ] whileFalse.
- Processor activeProcess suspend
-!
-
eofCommand
^'T'
!
@@ -503,43 +466,14 @@ Other commands:
x ..... exit Smalltalk'
! !
-
!MiniDebugger methodsFor: 'private'!
-initializeFor: aProcess
- process := aProcess.
- stepSemaphore := Semaphore new.
- methodSourceCodeCache := IdentityDictionary new.
- methodLineMapCache := IdentityDictionary new.
- activeContext := process suspendedContext.
- depth := 0.
-
- [ activeContext isInternalExceptionHandlingContext ]
- whileTrue: [ self finish ].
-
- self backtraceOf: process.
- self printCurrentLine.
-!
-
-backtraceOf: aProcess
- | context |
- context := aProcess == process
- ifTrue: [ activeContext ]
- ifFalse: [ aProcess suspendedContext ].
-
- context backtrace
-!
-
-depthOf: aContext
- | context depth |
- context := activeContext.
- depth := 0.
- [ context == aContext ] whileFalse: [
- context := context parentContext.
- context isNil ifTrue: [ ^nil ].
- depth := depth + 1.
- ].
- ^depth
+currentMethodSource
+ activeContext isNil ifTrue: [ ^#() ].
+ methodSourceCodeCache isNil ifTrue: [
+ methodSourceCodeCache := WeakKeyIdentityDictionary new ].
+ ^methodSourceCodeCache at: activeContext method ifAbsentPut: [
+ activeContext method methodSourceString lines ]
!
rightJustify: n
@@ -551,13 +485,24 @@ rightJustify: n
!
showProcesses
- self rightJustify: process asOop. '>' display. process printNl.
+ self rightJustify: debugger process asOop.
+ '>' display.
+ debugger process printNl.
+
Process allSubinstancesDo: [ :each |
- each == process
- ifFalse: [ self rightJustify: each asOop. ' ' display. each printNl
]
- ]
+ each == debugger process ifFalse: [
+ self rightJustify: each asOop.
+ ' ' display.
+ each printNl ] ]
! !
+!UndefinedObject methodsFor: 'polymorphism'!
+
+lines
+ ^nil
+! !
+
+
!Behavior methodsFor: 'debugging'!
--- orig/kernel/ContextPart.st
+++ mod/kernel/ContextPart.st
@@ -139,6 +139,19 @@ backtraceOn: aStream
!ContextPart methodsFor: 'debugging'!
+currentLine
+ "Answer the 1-based number of the line that is pointed to by the receiver's
+ instruction pointer. It is always 1 unless the DebugTools package is
+ loaded."
+ ^1
+!
+
+debugger
+ "Answer the debugger that is attached to the given context. It
+ is always nil unless the DebugTools package is loaded."
+ ^nil
+!
+
debuggerClass
"Answer which debugger should be used to debug the current
context chain. The class with the highest debugging
@@ -147,15 +160,15 @@ debuggerClass
ctx := self.
last := self class lastUnwindPoint.
[
- currentClass := ctx receiver class debuggerClass.
- currentClass isNil ifTrue: [ ^nil ].
- (debuggerClass isNil
- or: [ currentClass debuggingPriority > debuggerClass
debuggingPriority ])
- ifTrue: [ debuggerClass := currentClass ].
+ currentClass := ctx receiver class debuggerClass.
+ currentClass isNil ifTrue: [ ^nil ].
+ (debuggerClass isNil
+ or: [ currentClass debuggingPriority > debuggerClass
debuggingPriority ])
+ ifTrue: [ debuggerClass := currentClass ].
- ctx == last | ctx isNil
+ ctx == last | ctx isNil
] whileFalse: [
- ctx := ctx parentContext
+ ctx := ctx parentContext
].
^debuggerClass
!
--- orig/kernel/ExcHandling.st
+++ mod/kernel/ExcHandling.st
@@ -720,15 +720,16 @@ primError: message
"This might start the debugger... Note that we use #basicPrint
'cause #printOn: might invoke an error."
- | debuggerClass context |
+ | debugger debuggerClass context |
Transcript initialize.
stdout flush.
+
+ debugger := Processor activeDebugger.
+ debugger isNil ifFalse: [ ^debugger stopInferior: message ].
+
debuggerClass := thisContext debuggerClass.
debuggerClass isNil ifFalse: [
- ^debuggerClass
- openOn: Processor activeProcess
- message: self class printString, ' error: ', message
- ].
+ ^debuggerClass open: self class printString, ' error: ', message ].
"Default behavior - print backtrace"
RegressionTesting ifFalse: [ self basicPrint ].
--- orig/kernel/ProcSched.st
+++ mod/kernel/ProcSched.st
@@ -58,6 +58,11 @@ activeProcess
^activeProcess
!
+activeDebugger
+ "Answer the active process' debugger"
+ ^self activeProcess debugger
+!
+
activePriority
"Answer the active process' priority"
^self activeProcess priority
--- orig/kernel/Process.st
+++ mod/kernel/Process.st
@@ -58,6 +58,11 @@ on: aBlockClosure at: aPriority suspend:
!Process methodsFor: 'basic'!
+debugger
+ "Return the object in charge of debugging the receiver. This always
returns
+ nil unless the debugging package is loaded."
+ ^self context debugger!
+
context
"Return the execution context of the receiver."
^self == Processor activeProcess
--- orig/packages/browser/Debugger.st
+++ mod/packages/browser/Debugger.st
@@ -30,10 +30,9 @@
"
GuiData subclass: #Debugger
- instanceVariableNames: 'stacktrace contexts process stepSemaphore
+ instanceVariableNames: 'stacktrace contexts debugger
activeContext receiverInspector stackInspector
- listView theClass theMethod textView topView
- methodLineMapCache'
+ listView theClass theMethod textView topView'
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Browser'!
@@ -75,12 +74,10 @@ new: notifier
!Debugger methodsFor: 'initialize/release'!
init: notifier
- process := notifier process.
- stepSemaphore := Semaphore new.
- methodLineMapCache := IdentityDictionary new.
+ debugger := notifier debugger.
- [ process suspendedContext isInternalExceptionHandlingContext ]
- whileTrue: [ self finish ].
+ [ debugger suspendedContext isInternalExceptionHandlingContext ]
+ whileTrue: [ debugger slowFinish ].
self createWindowFrom: notifier.
!
@@ -191,7 +188,7 @@ contextSelectedFrom: assoc
highlight: context
| line |
- line := self lineFor: context.
+ line := context currentLine.
textView blox
gotoLine: line end: false;
selectFrom: 1 @ line to: 1 @ (line + 1)!
@@ -219,39 +216,51 @@ debugSelectors
#() #('Terminate' #terminateButtonCallback))
!
+updateAfter: aBlock
+ "If there's an exception, replace this window with another
+ notifier."
+ aBlock
+ on: SystemExceptions.DebuggerReentered
+ do: [ :ex |
+ topView close.
+ Notifier openOn: debugger process.
+ ^self ].
+
+ self updateContextList!
+
stepButtonCallback
- self step; updateContextList
+ self updateAfter: [ debugger step ]
!
nextButtonCallback
- self next; updateContextList
+ self updateAfter: [ debugger next ]
!
finishButtonCallback
- self finish; updateContextList
+ self updateAfter: [ debugger finish: activeContext ]
!
continueButtonCallback
topView close.
- self continue.
+ debugger continue.
!
killButtonCallback
topView close.
- process primTerminate
+ debugger process primTerminate
!
terminateButtonCallback
topView close.
- process terminate.
- self continue
+ debugger process terminate.
+ debugger continue
! !
!Debugger methodsFor: 'list pane'!
updateContextList
| context lastContext |
- context := process suspendedContext.
+ context := debugger suspendedContext.
lastContext := context environment.
stacktrace := OrderedCollection new.
contexts := OrderedCollection new.
@@ -265,7 +274,7 @@ updateContextList
].
self changeState: #stacktrace.
- self currentContext: process suspendedContext!
+ self currentContext: debugger suspendedContext!
currentContext: context
activeContext := context.
@@ -278,93 +287,6 @@ currentContext: context
self highlight: context! !
-!Debugger methodsFor: 'debugging operations'!
-
-depthOf: aContext
- | context depth |
- context := activeContext.
- depth := 0.
- [ context == aContext ] whileFalse: [
- context := context parentContext.
- context isNil ifTrue: [ ^nil ].
- depth := depth + 1.
- ].
- ^depth
-!
-
-currentLine
- ^self lineFor: process suspendedContext!
-
-lineFor: context
- | lineMap |
- context isNil ifTrue: [ ^1 ].
- lineMap := methodLineMapCache at: context method
- ifAbsentPut: [ context method sourceCodeMap ].
- ^lineMap at: context ip + 1 ifAbsent: [ 1 ]!
-
-stepBytecode
- "Execute a bytecode of the debugged process"
- process singleStepWaitingOn: stepSemaphore.
- process suspend.
-!
-
-step
- "Execute a line of the debugged process, going inside a message
- that is sent."
- | context line |
- context := process suspendedContext.
- line := self currentLine.
- [
- self stepBytecode.
- activeContext := process suspendedContext.
- activeContext == context and: [ line = self currentLine ]
- ] whileTrue.
-!
-
-next
- "Execute a line of the debugged process, stepping over a message
- that is sent."
- | context |
- context := process suspendedContext.
- [
- self step.
- activeContext notNil and: [ activeContext parentContext == context ]
- ] whileTrue: [
- self finish: activeContext
- ]
-!
-
-finish: aContext
- "Execute the debugged process until it returns from aContext"
- | context |
- [
- context := process suspendedContext.
- [
- self stepBytecode.
- process suspendedContext == context
- ] whileTrue.
-
- activeContext := process suspendedContext.
- activeContext notNil "no context? exit"
- and: [ activeContext parentContext == context "a send? go on"
- or: [ (self depthOf: aContext) notNil ]] "aContext still in the
chain? go on"
- ] whileTrue
-!
-
-finish
- "Execute the debugged process until it returns from the active context"
- self finish: activeContext
-!
-
-continue
- | proc |
- proc := Processor activeProcess.
- [ proc terminate. process resume ] forkAt: Processor unpreemptedPriority.
-
- "Suspend just in case we get here."
- proc suspend
-! !
-
!PrimitiveInspectorFieldList methodsFor: 'primitives'!
validSize: anObject
--- orig/packages/browser/Load.st
+++ mod/packages/browser/Load.st
@@ -36,4 +36,4 @@ Class allSubclassesDo: [ :each |
]!
(BLOX.BLOXBrowser includesKey: #BrowserMain)
- ifTrue: [ BLOX BLOXBrowser BrowserMain close ]!
+ ifTrue: [ BLOX.BLOXBrowser.BrowserMain close ]!
--- orig/packages/browser/Notifier.st
+++ mod/packages/browser/Notifier.st
@@ -30,8 +30,8 @@
"
GuiData subclass: #Notifier
- instanceVariableNames: 'callstackList process stacktrace
- currentSelection errMessage topView '
+ instanceVariableNames: 'callstackList debugger stacktrace
+ currentSelection errMessage topView listView '
classVariableNames: ''
poolDictionaries: ''
category: 'Graphics-Browser'!
@@ -51,40 +51,36 @@ debuggingPriority
!Notifier class methodsFor: 'instance creation'!
-openOn: process message: message
- | handleErrorsWithGui |
- handleErrorsWithGui := BLOX BLOXBrowser BrowserMain handleErrorsWithGui.
- BLOX BLOXBrowser BrowserMain handleErrorsWithGui: false.
- [
- Processor activeProcess name: 'Notifier/Debugger'.
- [ process isSuspended ] whileFalse: [ Processor yield ].
+openOn: aProcess message: message
+ self new init: message debugger: (Smalltalk.Debugger on: aProcess)!
- self new
- init: message
- process: process.
+open
+ self open: ('Notifier on %1' % { Processor activeProcess })!
- BLOX BLOXBrowser BrowserMain handleErrorsWithGui: handleErrorsWithGui.
- ] fork.
-
- process suspend.
+open: message
+ | handleErrorsWithGui |
+ handleErrorsWithGui := BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui.
+ BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui: false.
+ [ :debugger |
+ Processor activeProcess name: 'Notifier/Debugger'.
+ self new init: message debugger: debugger.
+ BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui: handleErrorsWithGui.
+ ] forkDebugger
! !
!Notifier methodsFor: 'accessing'!
currentContext
- currentSelection isNil ifTrue: [^nil].
+ currentSelection isNil ifTrue: [currentSelection := 1].
^callstackList at: currentSelection! !
!Notifier methodsFor: 'callback'!
-contexts
- ^callstackList elements!
-
-nameList
- ^callstackList labels!
-
process
- ^process!
+ ^debugger process!
+
+debugger
+ ^debugger!
contextSelectedFrom: assoc
currentSelection := assoc key!
@@ -102,11 +98,11 @@ close: aView
tv := aView rootView blox.
aView rootView close ifTrue: [tv destroy]!
-init: aString process: aProcess
+init: aString debugger: aDebugger
| context lastContext contexts |
errMessage := aString.
- process := aProcess.
- context := process suspendedContext.
+ debugger := aDebugger.
+ context := debugger suspendedContext.
lastContext := context environment.
stacktrace := OrderedCollection new.
contexts := OrderedCollection new.
@@ -129,10 +125,12 @@ init: aString process: aProcess
self createWindow.
callstackList contents: stacktrace elements: contexts.
- topView display!
+ topView display.
+ listView update.
+ listView select: 1!
createWindow
- | topLevel listView |
+ | topLevel |
topView := (BrowserShell new: errMessage) data: self.
topLevel := topView blox.
topLevel
--- orig/packages/browser/package.xml
+++ mod/packages/browser/package.xml
@@ -1,8 +1,11 @@
<package>
<name>Browser</name>
<namespace>BLOX.BLOXBrowser</namespace>
+
<prereq>Blox</prereq>
<prereq>Parser</prereq>
+ <prereq>DebugTools</prereq>
+
<filein>Load.st</filein>
<filein>GuiData.st</filein>
<filein>View.st</filein>
--- orig/tests/testsuite
+++ mod/tests/testsuite
@@ -620,7 +620,7 @@ at_times_file=$at_suite_dir/at-times
# List of the tested programs.
at_tested='gst'
# List of the all the test groups.
-at_groups_all=' banner-1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 banner-2 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 banner-3 41
42 banner-4 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 banner-5 108 109 110
111 112 113'
+at_groups_all=' banner-1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 banner-2 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 banner-3 41
42 banner-4 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 banner-5 108 109 110
111 112 113 114'
# As many question marks as there are digits in the last test group number.
# Used to normalize the test group numbers so that `ls' lists them in
# numerical order.
@@ -734,11 +734,12 @@ at_help_all="1;testsuite.at:27;arrays.st
106;testsuite.at:138;ZeroDivideANSITest;ANSI SUnit;
107;testsuite.at:139;ZeroDivideFactoryANSITest;ANSI SUnit;
108;testsuite.at:142;Continuations;Continuations SUnit;
-109;testsuite.at:143;DhbNumericalMethods;DhbNumericalMethods SUnit;
-110;testsuite.at:144;GDBM;GDBM SUnit;
-111;testsuite.at:145;MD5;MD5 SUnit;
-112;testsuite.at:146;ZLib;ZLib SUnit;
-113;testsuite.at:147;Iconv;Iconv SUnit;
+109;testsuite.at:143;DebugTools;DebugTools SUnit;
+110;testsuite.at:144;DhbNumericalMethods;DhbNumericalMethods SUnit;
+111;testsuite.at:145;GDBM;GDBM SUnit;
+112;testsuite.at:146;Iconv;Iconv SUnit;
+113;testsuite.at:147;MD5;MD5 SUnit;
+114;testsuite.at:148;ZLib;ZLib SUnit;
"
at_prev=
@@ -8527,10 +8528,10 @@ $at_traceon
at_status=`cat "$at_status_file"`
;;
- 109 ) # 109. testsuite.at:143: DhbNumericalMethods
+ 109 ) # 109. testsuite.at:143: DebugTools
at_setup_line='testsuite.at:143'
- at_desc="DhbNumericalMethods"
- $at_quiet $ECHO_N "109: DhbNumericalMethods
$ECHO_C"
+ at_desc="DebugTools"
+ $at_quiet $ECHO_N "109: DebugTools
$ECHO_C"
at_xfail=no
echo "# -*- compilation -*-" >> "$at_group_log"
(
@@ -8546,12 +8547,12 @@ $at_traceon
esac
$at_traceoff
-echo "$at_srcdir/testsuite.at:143: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo
exit \$? > retcode; } | tr -d '\\r'; . retcode"
+echo "$at_srcdir/testsuite.at:143: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit \$?
> retcode; } | tr -d '\\r'; . retcode"
echo testsuite.at:143 >"$at_check_line_file"
at_trace_this=
if test -n "$at_traceon"; then
- case "{ (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\\r'; . retcode" in
+ case "{ (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr
-d '\\r'; . retcode" in
*'
'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;;
*) at_trace_this=yes ;;
@@ -8559,12 +8560,12 @@ if test -n "$at_traceon"; then
fi
if test -n "$at_trace_this"; then
- ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1"
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr
-d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1"
at_status=$?
grep '^ *+' "$at_stder1" >&2
grep -v '^ *+' "$at_stder1" >"$at_stderr"
else
- ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr"
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr
-d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr"
at_status=$?
fi
@@ -8593,10 +8594,10 @@ $at_traceon
at_status=`cat "$at_status_file"`
;;
- 110 ) # 110. testsuite.at:144: GDBM
+ 110 ) # 110. testsuite.at:144: DhbNumericalMethods
at_setup_line='testsuite.at:144'
- at_desc="GDBM"
- $at_quiet $ECHO_N "110: GDBM
$ECHO_C"
+ at_desc="DhbNumericalMethods"
+ $at_quiet $ECHO_N "110: DhbNumericalMethods
$ECHO_C"
at_xfail=no
echo "# -*- compilation -*-" >> "$at_group_log"
(
@@ -8612,36 +8613,25 @@ $at_traceon
esac
$at_traceoff
-echo "$at_srcdir/testsuite.at:144: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p GDBM
- ret=\$?
- case \$ret in
- 2) exit 77 ;;
- 0|1) exit \$ret ;;
- esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode"
+echo "$at_srcdir/testsuite.at:144: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo
exit \$? > retcode; } | tr -d '\\r'; . retcode"
echo testsuite.at:144 >"$at_check_line_file"
at_trace_this=
if test -n "$at_traceon"; then
- echo 'Not enabling shell tracing (command contains an embedded newline)'
+ case "{ (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\\r'; . retcode" in
+ *'
+'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;;
+ *) at_trace_this=yes ;;
+ esac
fi
if test -n "$at_trace_this"; then
- ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p GDBM
- ret=$?
- case $ret in
- 2) exit 77 ;;
- 0|1) exit $ret ;;
- esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout"
2>"$at_stder1"
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1"
at_status=$?
grep '^ *+' "$at_stder1" >&2
grep -v '^ *+' "$at_stder1" >"$at_stderr"
else
- ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p GDBM
- ret=$?
- case $ret in
- 2) exit 77 ;;
- 0|1) exit $ret ;;
- esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout"
2>"$at_stderr"
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? >
retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr"
at_status=$?
fi
@@ -8670,10 +8660,10 @@ $at_traceon
at_status=`cat "$at_status_file"`
;;
- 111 ) # 111. testsuite.at:145: MD5
+ 111 ) # 111. testsuite.at:145: GDBM
at_setup_line='testsuite.at:145'
- at_desc="MD5"
- $at_quiet $ECHO_N "111: MD5
$ECHO_C"
+ at_desc="GDBM"
+ $at_quiet $ECHO_N "111: GDBM
$ECHO_C"
at_xfail=no
echo "# -*- compilation -*-" >> "$at_group_log"
(
@@ -8689,25 +8679,36 @@ $at_traceon
esac
$at_traceoff
-echo "$at_srcdir/testsuite.at:145: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p MD5); echo exit \$? >
retcode; } | tr -d '\\r'; . retcode"
+echo "$at_srcdir/testsuite.at:145: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p GDBM
+ ret=\$?
+ case \$ret in
+ 2) exit 77 ;;
+ 0|1) exit \$ret ;;
+ esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode"
echo testsuite.at:145 >"$at_check_line_file"
at_trace_this=
if test -n "$at_traceon"; then
- case "{ (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\\r'; . retcode" in
- *'
-'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;;
- *) at_trace_this=yes ;;
- esac
+ echo 'Not enabling shell tracing (command contains an embedded newline)'
fi
if test -n "$at_trace_this"; then
- ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\r'; . retcode ) >"$at_stdout" 2>"$at_stder1"
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p GDBM
+ ret=$?
+ case $ret in
+ 2) exit 77 ;;
+ 0|1) exit $ret ;;
+ esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout"
2>"$at_stder1"
at_status=$?
grep '^ *+' "$at_stder1" >&2
grep -v '^ *+' "$at_stder1" >"$at_stderr"
else
- ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\r'; . retcode ) >"$at_stdout" 2>"$at_stderr"
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p GDBM
+ ret=$?
+ case $ret in
+ 2) exit 77 ;;
+ 0|1) exit $ret ;;
+ esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout"
2>"$at_stderr"
at_status=$?
fi
@@ -8736,10 +8737,10 @@ $at_traceon
at_status=`cat "$at_status_file"`
;;
- 112 ) # 112. testsuite.at:146: ZLib
+ 112 ) # 112. testsuite.at:146: Iconv
at_setup_line='testsuite.at:146'
- at_desc="ZLib"
- $at_quiet $ECHO_N "112: ZLib
$ECHO_C"
+ at_desc="Iconv"
+ $at_quiet $ECHO_N "112: Iconv
$ECHO_C"
at_xfail=no
echo "# -*- compilation -*-" >> "$at_group_log"
(
@@ -8755,7 +8756,7 @@ $at_traceon
esac
$at_traceoff
-echo "$at_srcdir/testsuite.at:146: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p ZLib
+echo "$at_srcdir/testsuite.at:146: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p Iconv
ret=\$?
case \$ret in
2) exit 77 ;;
@@ -8769,7 +8770,7 @@ if test -n "$at_traceon"; then
fi
if test -n "$at_trace_this"; then
- ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p ZLib
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p Iconv
ret=$?
case $ret in
2) exit 77 ;;
@@ -8779,7 +8780,7 @@ if test -n "$at_trace_this"; then
grep '^ *+' "$at_stder1" >&2
grep -v '^ *+' "$at_stder1" >"$at_stderr"
else
- ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p ZLib
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p Iconv
ret=$?
case $ret in
2) exit 77 ;;
@@ -8813,10 +8814,10 @@ $at_traceon
at_status=`cat "$at_status_file"`
;;
- 113 ) # 113. testsuite.at:147: Iconv
+ 113 ) # 113. testsuite.at:147: MD5
at_setup_line='testsuite.at:147'
- at_desc="Iconv"
- $at_quiet $ECHO_N "113: Iconv
$ECHO_C"
+ at_desc="MD5"
+ $at_quiet $ECHO_N "113: MD5
$ECHO_C"
at_xfail=no
echo "# -*- compilation -*-" >> "$at_group_log"
(
@@ -8832,13 +8833,79 @@ $at_traceon
esac
$at_traceoff
-echo "$at_srcdir/testsuite.at:147: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p Iconv
+echo "$at_srcdir/testsuite.at:147: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p MD5); echo exit \$? >
retcode; } | tr -d '\\r'; . retcode"
+echo testsuite.at:147 >"$at_check_line_file"
+
+at_trace_this=
+if test -n "$at_traceon"; then
+ case "{ (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\\r'; . retcode" in
+ *'
+'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;;
+ *) at_trace_this=yes ;;
+ esac
+fi
+
+if test -n "$at_trace_this"; then
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\r'; . retcode ) >"$at_stdout" 2>"$at_stder1"
+ at_status=$?
+ grep '^ *+' "$at_stder1" >&2
+ grep -v '^ *+' "$at_stder1" >"$at_stderr"
+else
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d
'\r'; . retcode ) >"$at_stdout" 2>"$at_stderr"
+ at_status=$?
+fi
+
+at_failed=false
+$at_diff "$at_devnull" "$at_stderr" || at_failed=:
+echo stdout:; cat "$at_stdout"
+case $at_status in
+ 77) echo 77 > "$at_status_file"; exit 77;;
+ 0) ;;
+ *) echo "$at_srcdir/testsuite.at:147: exit code was $at_status, expected 0"
+ at_failed=:;;
+esac
+if $at_failed; then
+
+
+ echo 1 > "$at_status_file"
+ exit 1
+fi
+
+$at_traceon
+
+
+ $at_traceoff
+ $at_times_p && times >"$at_times_file"
+ ) 5>&1 2>&1 | eval $at_tee_pipe
+ at_status=`cat "$at_status_file"`
+ ;;
+
+ 114 ) # 114. testsuite.at:148: ZLib
+ at_setup_line='testsuite.at:148'
+ at_desc="ZLib"
+ $at_quiet $ECHO_N "114: ZLib
$ECHO_C"
+ at_xfail=no
+ echo "# -*- compilation -*-" >> "$at_group_log"
+ (
+ echo "114. testsuite.at:148: testing ..."
+ $at_traceon
+
+
+
+
+ case $AUTOTEST_PATH in
+ tests) image_path="-I $abs_top_builddir/gst.im" ;;
+ *) image_path="" ;;
+ esac
+
+ $at_traceoff
+echo "$at_srcdir/testsuite.at:148: { (cd \$abs_top_builddir && gst
\$image_path -f \$abs_top_srcdir/scripts/Test.st -p ZLib
ret=\$?
case \$ret in
2) exit 77 ;;
0|1) exit \$ret ;;
esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode"
-echo testsuite.at:147 >"$at_check_line_file"
+echo testsuite.at:148 >"$at_check_line_file"
at_trace_this=
if test -n "$at_traceon"; then
@@ -8846,7 +8913,7 @@ if test -n "$at_traceon"; then
fi
if test -n "$at_trace_this"; then
- ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p Iconv
+ ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p ZLib
ret=$?
case $ret in
2) exit 77 ;;
@@ -8856,7 +8923,7 @@ if test -n "$at_trace_this"; then
grep '^ *+' "$at_stder1" >&2
grep -v '^ *+' "$at_stder1" >"$at_stderr"
else
- ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p Iconv
+ ( :; { (cd $abs_top_builddir && gst $image_path -f
$abs_top_srcdir/scripts/Test.st -p ZLib
ret=$?
case $ret in
2) exit 77 ;;
@@ -8871,7 +8938,7 @@ echo stdout:; cat "$at_stdout"
case $at_status in
77) echo 77 > "$at_status_file"; exit 77;;
0) ;;
- *) echo "$at_srcdir/testsuite.at:147: exit code was $at_status, expected 0"
+ *) echo "$at_srcdir/testsuite.at:148: exit code was $at_status, expected 0"
at_failed=:;;
esac
if $at_failed; then
--- orig/tests/testsuite.at
+++ mod/tests/testsuite.at
@@ -140,8 +140,9 @@ AT_ANSI_TEST([ZeroDivideFactoryANSITest]
AT_BANNER([Other packages.])
AT_PACKAGE_TEST([Continuations])
+AT_PACKAGE_TEST([DebugTools])
AT_PACKAGE_TEST([DhbNumericalMethods])
AT_OPTIONAL_PACKAGE_TEST([GDBM])
+AT_OPTIONAL_PACKAGE_TEST([Iconv])
AT_PACKAGE_TEST([MD5])
AT_OPTIONAL_PACKAGE_TEST([ZLib])
-AT_OPTIONAL_PACKAGE_TEST([Iconv])
* added files
--- /dev/null
+++ mod/packages/debug/DebugTools.st
@@ -0,0 +1,353 @@
+"======================================================================
+|
+| Inferior process control
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2002, 2006, 2007 Free Software Foundation, Inc.
+| Written by Paolo Bonzini.
+|
+| This file is part of GNU Smalltalk.
+|
+| GNU Smalltalk is free software; you can redistribute it and/or modify it
+| under the terms of the GNU General Public License as published by the Free
+| Software Foundation; either version 2, or (at your option) any later version.
+|
+| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
+| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+| details.
+|
+| You should have received a copy of the GNU General Public License along with
+| GNU Smalltalk; see the file COPYING. If not, write to the Free Software
+| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+|
+ ======================================================================"
+
+
+Object subclass: #Debugger
+ instanceVariableNames: 'debugProcess process breakpointContext
+ stepSemaphore '
+ classVariableNames: 'MethodLineMapCache'
+ poolDictionaries: ''
+ category: 'System-Debugging'
+!
+
+Debugger comment:
+'I provide debugging facilities for another inferior process. I have
+methods that allow the controlled process to proceed with varying
+granularity. In addition, I keep a cache mapping instruction
+pointer bytecodes to line numbers.'!
+
+Namespace current: SystemExceptions!
+
+Notification subclass: #DebuggerReentered
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'System-Debugging'
+!
+
+DebuggerReentered comment:
+'This notification is raised when the debugger is started on a process
+that was already being debugged. Trapping it allows the pre-existing
+debugger to keep control of the process.'!
+
+!DebuggerReentered methodsFor: 'description'!
+
+description
+ "Answer a textual description of the exception."
+ ^'the debugger was started on an already debugged process'! !
+
+Namespace current: Smalltalk!
+
+!Debugger class methodsFor: 'source code'!
+
+currentLineIn: aContext
+ | lineMap method |
+ method := aContext method.
+ MethodLineMapCache isNil ifTrue: [
+ MethodLineMapCache := WeakKeyIdentityDictionary new ].
+ lineMap := MethodLineMapCache
+ at: method
+ ifAbsentPut: [ method sourceCodeMap ].
+ ^lineMap
+ at: aContext ip + 1
+ ifAbsent: [ 1 ]
+! !
+
+!Debugger class methodsFor: 'instance creation'!
+
+on: aProcess
+ "Suspend aProcess and return a new Debugger that controls aProcess.
+ aProcess must not be the currently running process."
+ aProcess == Processor activeProcess
+ ifTrue: [self error: 'cannot attach to current process'].
+ aProcess suspend.
+ ^self new initializeFor: aProcess! !
+
+!Debugger class methodsFor: 'disabling debugging'!
+
+debuggerClass
+ ^nil
+! !
+
+!Debugger methodsFor: 'inferior process properties'!
+
+isActive
+ "Answer true if the inferior process is still running."
+ ^process notNil and: [ process suspendedContext notNil ]
+!
+
+process
+ "Answer the inferior process."
+ ^process
+!
+
+currentLine
+ "Return the line number in traced process."
+ self isActive ifFalse: [ ^'' ].
+ ^self suspendedContext currentLine
+!
+
+suspendedContext
+ "Answer the suspended execution state of the inferior process."
+ ^process suspendedContext
+! !
+
+!Debugger methodsFor: 'stepping commands'!
+
+stopInferior
+ "Suspend the inferior process and raise a DebuggerReentered notification
+ in the controlling process."
+ self stopInferior: nil
+!
+
+stopInferior: anObject
+ "Suspend the inferior process and raise a DebuggerReentered notification
+ in the controlling process with anObject as the exception's message."
+ | exception |
+ [
+ [
+ process suspend.
+ debugProcess
+ queueInterrupt: [
+ self disableBreakpointContext.
+ SystemExceptions.DebuggerReentered signal: anObject ];
+ resume.
+ ] on: Exception do: [ :ex |
+ exception := ex.
+ process resume
+ ].
+ ] forkAt: Processor unpreemptedPriority.
+
+ "Pass the exception on in the calling process."
+ exception isNil ifFalse: [ exception signal ]
+!
+
+stepBytecode
+ "Run a single bytecode in the inferior process."
+ debugProcess := Processor activeProcess.
+ process singleStepWaitingOn: stepSemaphore.
+ process suspend.
+ debugProcess := nil.
+!
+
+step
+ "Run to the end of the current line in the inferior process or to the
+ next message send."
+ | context line |
+ context := self suspendedContext.
+ line := self currentLine.
+ [
+ self stepBytecode.
+ self suspendedContext == context and: [ line = self currentLine ]
+ ] whileTrue
+!
+
+next
+ "Run to the end of the current line in the inferior process, skipping
+ over message sends."
+ | context line |
+ context := self suspendedContext.
+ line := self currentLine.
+ [
+ self stepBytecode.
+ (self suspendedContext notNil
+ and: [ self suspendedContext parentContext == context ])
+ ifTrue: [ self finish: self suspendedContext ].
+ self suspendedContext == context and: [ line = self currentLine ]
+ ] whileTrue
+!
+
+finish
+ "Run to the next return."
+ self finish: self suspendedContext
+!
+
+finish: aContext
+ "Run up until aContext returns."
+ <debugging: true>
+ | proc cont context retVal |
+
+ "First, use the slow scheme for internal exception handling contexts.
+ These are more delicate and in general pretty small, so it is not
+ expensive."
+ aContext isInternalExceptionHandlingContext
+ ifTrue: [ ^self slowFinish: aContext ].
+ [ self suspendedContext isInternalExceptionHandlingContext ]
+ whileTrue: [ self slowFinish: self suspendedContext ].
+
+ "Create a context that will restart the debugger and place it in the
+ chain. We don't really use the continuation object directly but,
+ if we use the methods in Continuation, we are sure that contexts
+ are set up correctly."
+ debugProcess := Processor activeProcess.
+ retVal := Continuation currentDo: [ :cc | cont := cc ].
+ Processor activeProcess == debugProcess
+ ifTrue: [
+ "Put our context below aContext and restart the debugged process."
+ context := cont stack.
+
+ context instVarAt: MethodContext instSize put: 2.
+ context parentContext: aContext parentContext.
+ aContext parentContext: context.
+ [
+ breakpointContext := aContext.
+ debugProcess suspend.
+ process resume.
+ ] forkAt: Processor unpreemptedPriority.
+
+ "Finish the continuation context, which is at the `retVal' line
+ below."
+ debugProcess := nil.
+ self slowFinish: context ]
+
+ ifFalse: [
+ "We arrive here when we finish execution of aContext. Put the
+ debugger process in control again."
+ [
+ breakpointContext := nil.
+ process suspend.
+ debugProcess resume
+ ] forkAt: Processor unpreemptedPriority.
+ ^retVal ]
+!
+
+slowFinish
+ "Run in single-step mode up to the next return."
+ self slowFinish: self suspendedContext
+!
+
+slowFinish: aContext
+ "Run in single-step mode until aContext returns."
+ | context newContext |
+ context := self suspendedContext.
+ [
+ [
+ self stepBytecode.
+ self suspendedContext == context
+ ] whileTrue.
+
+ newContext := self suspendedContext.
+
+ newContext notNil "no context? exit"
+ and: [
+ "a send? go on"
+ newContext parentContext == context or: [
+ "aContext still in the chain? go on"
+ self includes: aContext ] ]
+ ] whileTrue.
+!
+
+continue
+ "Terminate the controlling process and continue execution of the
+ traced process."
+ | theDebugProcess theProcess |
+ theDebugProcess := Processor activeProcess.
+ theProcess := process.
+ [
+ debugProcess := nil.
+ process := nil.
+ theDebugProcess terminate.
+ theProcess resume
+ ] forkAt: Processor unpreemptedPriority.
+
+ "Just in case we get here."
+ theDebugProcess primTerminate
+! !
+
+
+!Debugger methodsFor: 'private'!
+
+disableBreakpointContext
+ "Remove the context inserted set by #finish:."
+ | theBreakpointContext |
+ theBreakpointContext := breakpointContext.
+ breakpointContext := nil.
+ debugProcess := nil.
+
+ theBreakpointContext isNil ifFalse: [
+ theBreakpointContext
+ parentContext: theBreakpointContext parentContext parentContext ]!
+
+includes: aContext
+ "Answer whether aContext is still in the stack of the traced process."
+ | context |
+ context := self suspendedContext.
+ [
+ context isNil ifTrue: [ ^false ].
+ context == aContext ifTrue: [ ^true ].
+ context := context parentContext.
+ ] repeat
+!
+
+initializeFor: aProcess
+ process := aProcess.
+ stepSemaphore := Semaphore new!
+
+
+!ContextPart methodsFor: 'source code'!
+
+currentLine
+ "Answer the 1-based number of the line that is pointed to by the receiver's
+ instruction pointer."
+ ^Debugger currentLineIn: self
+!
+
+!ContextPart methodsFor: 'debugging'!
+
+debugger
+ "Answer the debugger that is attached to the given context. It
+ is always nil unless the DebugTools package is loaded."
+ | ctx home |
+ ctx := self.
+ [ ctx isNil ] whileFalse: [
+ home := ctx home.
+ (home notNil and: [
+ (home method attributeAt: #debugging: ifAbsent: [ nil ]) notNil])
+ ifTrue: [ ^ctx receiver ].
+
+ ctx := ctx parentContext ].
+ ^nil
+! !
+
+!BlockClosure methodsFor: 'instance creation'!
+
+forkDebugger
+ "Suspend the currently running process and fork the receiver into a new
+ process, passing a Debugger object that controls the currently running
+ process."
+ | process |
+ process := Processor activeProcess.
+ [
+ process suspend.
+ Processor activeProcess priority: process priority.
+ self value: (Debugger on: process)
+ ] forkAt: Processor unpreemptedPriority.
+! !
+
--- /dev/null
+++ mod/packages/debug/debugtests.st
@@ -0,0 +1,248 @@
+"======================================================================
+|
+| DebugTools package unit tests
+|
+|
+ ======================================================================"
+
+
+"======================================================================
+|
+| Copyright 2007 Free Software Foundation, Inc.
+| Written by Paolo Bonzini
+|
+| This file is part of GNU Smalltalk.
+|
+| GNU Smalltalk is free software; you can redistribute it and/or modify it
+| under the terms of the GNU General Public License as published by the Free
+| Software Foundation; either version 2, or (at your option) any later version.
+|
+| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
+| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+| details.
+|
+| You should have received a copy of the GNU General Public License along with
+| GNU Smalltalk; see the file COPYING. If not, write to the Free Software
+| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+|
+ ======================================================================"
+
+PackageLoader fileInPackage: #SUnit!
+
+TestCase subclass: #DebuggerTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'System-Debugging-Test'!
+
+!DebuggerTest methodsFor: 'test'!
+
+debuggerOn: aBlock
+ "Attach aBlock to a debugger and step until aBlock's execution begins."
+ | debugger |
+ debugger := Debugger
+ on: [ Processor activeProcess suspend. aBlock value ] fork.
+ [ debugger suspendedContext method == aBlock block ]
+ whileFalse: [ debugger stepBytecode ].
+ ^debugger!
+
+testOn
+ "Test that #debuggerOn: works as we intend."
+ | debugger notReached |
+ notReached := false.
+ debugger := self debuggerOn: [ notReached := true ].
+ self assert: debugger suspendedContext isBlock.
+ self deny: notReached!
+
+testStep
+ "Test that #step goes through the traced process a single line at a time."
+ | debugger reached1 reached2 notReached |
+ reached1 := reached2 := notReached := false.
+ debugger := self debuggerOn: [
+ reached1 := true. reached2 := true.
+ notReached := true ].
+ debugger step.
+ self assert: reached1.
+ self assert: reached2.
+ self deny: notReached!
+
+testCurrentLine
+ "Test that #currentLine does not do something completely bogus."
+ | debugger a b c prevLine |
+ debugger := self debuggerOn: [
+ a := 5.
+ b := 6.
+ c := 7 ].
+
+ [ debugger step. a = 5 ] whileFalse.
+ prevLine := debugger currentLine.
+ debugger step.
+ self assert: prevLine + 1 = debugger currentLine!
+
+testForkDebugger
+ "Test forking a debugger for the current process."
+ | value |
+ [ :debugger |
+ [ debugger step. debugger suspendedContext selector = #y ] whileFalse.
+ value := false.
+ debugger finish.
+ [ debugger step. debugger suspendedContext selector = #y ] whileFalse.
+ value := true.
+ debugger finish.
+ [ debugger step. debugger suspendedContext selector = #y ] whileFalse.
+ value := 42.
+ debugger continue
+ ] forkDebugger.
+ self y.
+ self deny: value.
+ self y.
+ self assert: value.
+ self y.
+ self assert: value = 42!
+
+testStopInferior
+ "Test using #stopInferior to restart the debugger."
+ | theDebugger value |
+ [ :debugger |
+ theDebugger := debugger.
+ [ [ debugger step ] repeat ]
+ on: SystemExceptions.DebuggerReentered
+ do: [ :ex | ex return ].
+
+ value := 42.
+ debugger continue
+ ] forkDebugger.
+
+ self assert: value isNil.
+ theDebugger stopInferior.
+ self assert: value = 42!
+
+testStepIntoSend
+ "Test that #step stops at the next message send."
+ | debugger reached notReached |
+ reached := false.
+ debugger := self debuggerOn: [
+ reached := true. notReached := 3 factorial ].
+ debugger step.
+ self assert: reached.
+ self assert: notReached isNil!
+
+testFinish
+ "Test that #finish does not proceed further in the parent context."
+ | debugger reached |
+ debugger := self debuggerOn: [
+ reached := 3 factorial ].
+ debugger step.
+ self assert: reached isNil.
+ debugger finish.
+ "The assignment has not been executed yet."
+ self assert: reached isNil.
+ debugger finish.
+ self assert: reached = 6!
+
+testStepTooMuch
+ "Test that #stepBytecode eventually raises an error."
+ | debugger reached toFinish |
+ debugger := self debuggerOn: [ 3 factorial ].
+ self
+ should: [ [debugger stepBytecode] repeat ]
+ raise: Error.
+ self deny: debugger isActive!
+
+testFinishColon
+ "Test using #finish: to leave multiple contexts at once."
+ | debugger reached toFinish |
+ debugger := self debuggerOn: [
+ self x: [ :foo | reached := foo ]
+ ].
+
+ [
+ debugger step.
+ debugger suspendedContext selector = #x: ] whileFalse.
+
+ toFinish := debugger suspendedContext.
+ [
+ debugger step.
+ debugger suspendedContext selector = #z: ] whileFalse.
+
+ debugger finish: toFinish.
+ self assert: reached = 42.
+ self deny: debugger suspendedContext selector = #x:!
+
+testContinue
+ "Test that #continue terminates the controlling process."
+ | debugger reached sema1 sema2 curtailed |
+ debugger := self debuggerOn: [
+ reached := 3 factorial.
+ sema1 signal ].
+
+ sema1 := Semaphore new.
+ sema2 := Semaphore new.
+ curtailed := true.
+ [
+ "The controlling process is terminated, so we run the test in another
+ process."
+ [
+ debugger continue.
+ curtailed := false
+ ] ensure: [ sema2 signal ].
+ ] fork.
+
+ sema1 wait.
+ sema2 wait.
+ self assert: reached = 6.
+ self assert: curtailed.
+ self deny: debugger isActive!
+
+testStepOverPrimitive
+ "Test that #step does not go inside a primitive."
+ | debugger reached notReached |
+ debugger := self debuggerOn: [
+ reached := Object new ].
+ debugger step.
+ self assert: reached notNil!
+
+testNext
+ "Test that #next runs a whole line independent of how many sends are
there."
+ | debugger reached1 reached2 |
+ debugger := self debuggerOn: [
+ reached1 := 3 factorial. reached2 := 4 factorial ].
+ debugger next.
+ self assert: reached1 = 6.
+ self assert: reached2 = 24!
+
+testCurtailFinish
+ "Test that finish is not fooled by method returns."
+ | debugger notReached |
+ notReached := false.
+ debugger := self debuggerOn: [ self w. notReached := true ].
+
+ [ debugger step. debugger suspendedContext selector = #z: ]
+ whileFalse.
+
+ debugger finish.
+ self assert: debugger suspendedContext selector = #y.
+ debugger finish.
+ self assert: debugger suspendedContext selector = #x:.
+ debugger step.
+ self assert: debugger suspendedContext isBlock.
+ self assert: debugger suspendedContext selector = #w.
+ debugger finish.
+ self assert: debugger isActive.
+ self deny: notReached! !
+
+!DebuggerTest methodsFor: 'support'!
+
+w
+ self x: [ :foo | ^foo ]!
+
+x: aBlock
+ aBlock value: self y!
+
+y
+ ^self z: 42!
+
+z: anObject
+ ^anObject! !
+
--- /dev/null
+++ mod/packages/debug/package.xml
@@ -0,0 +1,13 @@
+<package>
+ <name>DebugTools</name>
+
+ <test>
+ <sunit>DebuggerTest</sunit>
+ <filein>debugtests.st</filein>
+ </test>
+
+ <filein>DebugTools.st</filein>
+
+ <file>DebugTools.st</file>
+ <file>debugtests.st</file>
+</package>
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] DebugTools package,
Paolo Bonzini <=