"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

Object subclass:#MiniDebugger

	instanceVariableNames:'tracing stepping traceBlock command commandArg commandCount

	classVariableNames:'TheOneAndOnlyDebugger'

	poolDictionaries:''

	category:'System-Debugging-Support'

!

!MiniDebugger class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    a primitive (non graphical) debugger for use on systems without

    graphics or when the real debugger dies (i.e. an error occurs in

    the graphical debugger).

    Also, if an interrupt occurs within the debuger, this one is called

    for.

    [author:]

        Claus Gittinger

"

! !

!MiniDebugger class methodsFor:'instance creation'!

enter:aContext withMessage:aString mayProceed:mayProceed

    "enter a miniDebugger"

    |active con|

    StepInterruptPending := nil.

    Object errorSignal handle:[:ex |

        ex return

    ] do:[

        thisContext isRecursive ifTrue:[

            "/ 'recursive error in debugger ignored' errorPrintCR.

            ^ self

        ].

        aString printCR.

        Processor notNil ifTrue:[

            active := Processor activeProcess.

            'process: id=' print. active id print. 

            ' name=' print. active name printCR.

	    'context: ' print. aContext printString printCR.

	    (con := aContext) notNil ifTrue:[

		con := con sender.

		' ......: ' print. con printString printCR.

	        [con notNil] whileTrue:[

		    con := con sender.

		    ' ......: ' print. con printString printCR.

	        ]

	    ]

        ].

    ].

    OperatingSystem hasConsole ifFalse:[

        Object errorSignal handle:[:ex |

            ex return

        ] do:[

            self warn:('Unexpected error:\' , aString , '\\No MiniDebugger functionality available') withCRs .

        ].

        Object errorSignal handle:[:ex |

	    'cannot raise AbortSignal - exiting ...' errorPrintCR.

            Smalltalk exit.

        ] do:[

            AbortSignal raise.

        ]

    ] ifTrue:[

        self new enter:aContext mayProceed:mayProceed.

    ].

    mayProceed ifFalse:[

	AbortSignal raise

    ].

    ^ nil

    "Modified: / 19.5.1999 / 18:14:33 / cg"

!

enterWithMessage:aString mayProceed:mayProceed

    "enter a miniDebugger"

    self enter:thisContext sender withMessage:aString mayProceed:mayProceed

    "Modified: / 19.5.1999 / 18:14:33 / cg"

!

new

    "redefined to make certain that there is only one miniDebugger

     in the system"

    ^ self basicNew initialize.

    "

     TheOneAndOnlyDebugger := nil

    "

    "Modified: / 31.7.1998 / 17:08:07 / cg"

!

openOn:aProcess

    "enter a miniDebugger"

    self 

        enter:thisContext sender 

        withMessage:'MiniDebugger [info]: Attention - process debugging not possible.' 

        mayProceed:true

    "Modified: / 19.5.1999 / 18:14:33 / cg"

!

singleStep:aBlock

    |aDebugger|

    aDebugger := self new stepping.

    ObjectMemory stepInterruptHandler:aDebugger.

    ObjectMemory flushInlineCaches.

    StepInterruptPending := 1.

    InterruptPending := 1.

    aBlock value.

    StepInterruptPending := nil.

    ObjectMemory stepInterruptHandler:nil

!

trace:aBlock

    self trace:aBlock with:[:where | where printCR]

    "Modified: 20.5.1996 / 10:27:37 / cg"

!

trace:aBlock on:aStream

    self trace:aBlock with:[:where | where printString printOn:aStream.

				     aStream cr]

!

trace:aBlock with:aTraceBlock

    |aDebugger|

    aDebugger := self new tracingWith:aTraceBlock.

    ObjectMemory stepInterruptHandler:aDebugger.

    ObjectMemory flushInlineCaches.

    StepInterruptPending := 1.

    InterruptPending := 1.

    aBlock value.

    ObjectMemory stepInterruptHandler:nil.

    StepInterruptPending := nil.

    ^ nil

! !

!MiniDebugger methodsFor:'initialization'!

initialize

    traceBlock := nil.

    tracing := false.

    stepping := false

! !

!MiniDebugger methodsFor:'interrupt handling'!

enter:aContext mayProceed:mayProceed

    |c leaveCmd stillHere yesNo|

    enteringContext := dot := aContext.

    nesting := 0.

    c := aContext.

    [c notNil] whileTrue:[

	c selector == #enter:mayProceed: ifTrue:[

	    nesting := nesting + 1.

	].

	c := c sender.

    ].

    stillHere := true.

    [stillHere] whileTrue:[

	AbortSignal handle:[:ex |

	    '** Abort Signal cought - back in previous debugLevel' printCR.

	] do:[

	    Object errorSignal handle:[:ex |

	        'Error while executing command: ' print.

		ex description printCR.

                yesNo := self getCommand:'- (i)gnore / (p)roceed / (d)ebug ? '.

	        yesNo == $d ifTrue:[

		    ex reject

	        ].

	        yesNo == $p ifTrue:[

		    ex proceed

	        ].

	    ] do:[

                leaveCmd := self commandLoop.

	    ].

	].

        (leaveCmd == $s) ifTrue: [

            self stepping.

            ObjectMemory flushInlineCaches.

            ObjectMemory stepInterruptHandler:self.

            stillHere := false.

            StepInterruptPending := 1.

            InterruptPending := 1

        ].

        (leaveCmd == $t) ifTrue: [

            traceBlock := [:where | where fullPrint].

            ObjectMemory flushInlineCaches.

            ObjectMemory stepInterruptHandler:self.

            stillHere := false.

            StepInterruptPending := 1.

            InterruptPending := 1

        ].

        (leaveCmd == $c) ifTrue: [

            traceBlock := nil.

            stillHere := false.

            stepping := false.

            tracing := false.

            StepInterruptPending := nil.

            InterruptPending := nil

        ].

        (leaveCmd == $a) ifTrue: [

            "abort"

            stepping := false.

            tracing := false.

            StepInterruptPending := nil.

            InterruptPending := nil.

            self doAbort.

            stillHere := true.

            "failed abort"

        ].

    ].

    enteringContext := dot := nil.

    ^ nil

    "Modified: / 18.8.1998 / 18:10:29 / cg"

!

stepInterrupt

    |where|

    where := thisContext.        "where is stepInterrupt context"

    where notNil ifTrue:[

        where := where sender    "where is now interrupted methods context"

    ].

    stepping ifTrue:[

        where notNil ifTrue:[

            where fullPrint

        ] ifFalse:[

            'stepInterrupt: no context' errorPrintCR

        ].

        self enter:where mayProceed:true

    ] ifFalse:[

        where notNil ifTrue:[

            traceBlock notNil ifTrue:[

                traceBlock value:where

            ]

        ] ifFalse:[

            'traceInterrupt: no context' errorPrintCR

        ].

        ObjectMemory flushInlineCaches.

        StepInterruptPending := 1.

        InterruptPending := 1

    ]

    "Modified: 20.5.1996 / 10:23:11 / cg"

! !

!MiniDebugger methodsFor:'private'!

findContext:aSelector

    |con|

    con := thisContext sender.

    [con notNil] whileTrue:[

	(con isBlockContext not and:[con selector == aSelector]) ifTrue:[

	    "got it"

	    ^ con

	].

	con := con sender

    ].

    ^ nil

!

getContext

    |backtrace|

    backtrace := thisContext.

    (backtrace notNil) ifTrue: [

	"remove Context getContext frame"

	backtrace := backtrace sender.

	"remove Debugger showContext frame"

	backtrace := backtrace sender.

	"remove Debugger commandLoop frame"

	backtrace := backtrace sender.

	"remove Debugger enter frame"

	backtrace := backtrace sender

    ].

    ^ backtrace

!

printBacktraceFrom:aContext

    |context n|

    aContext isNil ifTrue:[

        'no context' errorPrintCR.

        ^ self

    ].

    context := aContext.

    n := commandCount.

    [context notNil] whileTrue: [

        context fullPrint.

        context := context sender.

        n notNil ifTrue:[

            n := n - 1.

            n <= 0 ifTrue:[

                ^ self

            ]

        ]

    ]

!

stepping

    traceBlock := nil.

    tracing := false.

    stepping := true

!

tracingWith:aBlockOrNil

    traceBlock := aBlockOrNil.

    stepping := false.

    tracing := true

! !

!MiniDebugger methodsFor:'user commands'!

commandLoop

    |cmd done valid context id proc|

    done := false.

    [done] whileFalse:[

        valid := false.

        cmd := self getCommand:nil.

        cmd isNil ifTrue:[   "/ EOF -> continue

            cmd := $c

        ].

        commandArg notEmpty ifTrue:[

            id := Number readFrom:commandArg onError:nil.

            id notNil ifTrue:[

                proc := Process allSubInstances detect:[:p | p id == id] ifNone:nil.

                proc == Processor activeProcess ifTrue:[

                    id := proc := nil

                ]

            ]

        ].

        (cmd == $l) ifTrue:[

            valid := true.

            proc notNil ifTrue:[

                '-------- walkback of process ' print. id print. ' -------' printCR.

                self printBacktraceFrom:(proc suspendedContext)

            ] ifFalse:[

                id notNil ifTrue:[

                    'no process with id: ' print. id printCR.

                ] ifFalse:[

                    context isNil ifTrue: [

                        context := self getContext

                    ].

                    '-------- walkback of current process -------' printCR.

                    self printBacktraceFrom:context

                ]

            ].

        ].

        (cmd == $b) ifTrue:[

            valid := true.

            proc notNil ifTrue:[

                '-------- VM walkback of process ' print. id print. ' -------' printCR.

                ObjectMemory printStackBacktraceFrom:(proc suspendedContext)

            ] ifFalse:[

                id notNil ifTrue:[

                    'no process with id: ' print. id printCR.

                ] ifFalse:[

                    '-------- VM walkback of current process -------' printCR.

                    ObjectMemory printStackBacktrace

                ]

            ]

        ].

	(cmd == $S) ifTrue:[

	    valid := true.

	    ObjectMemory snapShotOn:'crash.img'.

	].

        (cmd == $B) ifTrue:[

            valid := true.

            self printAllBacktraces

        ].

        (cmd == $P) ifTrue:[

            valid := true.

            self showProcesses.

        ].

        (cmd == $r) ifTrue:[

            valid := true.

            dot receiver printCR

        ].

        (cmd == $i) ifTrue:[

            valid := true.

            MiniInspector openOn:(dot receiver)

        ].

        (cmd == $I) ifTrue:[

            valid := true.

            self interpreterLoopWith:nil

        ].

        context := nil.

        (cmd == $c) ifTrue:[valid := true. done := true].

        (cmd == $s) ifTrue:[valid := true. done := true].

        (cmd == $t) ifTrue:[valid := true. done := true].

        (cmd == $a) ifTrue:[valid := true. done := true].

        (cmd == $u) ifTrue:[

            stepping := false.

            tracing := false.

            Processor activeProcess vmTrace:false.