"

 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.

"

"{ Package: 'stx:libbasic' }"

Object subclass:#MiniDebugger

	instanceVariableNames:'tracing stepping traceBlock command commandArg commandCount

		enteringContext dot nesting'

	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.

    MiniDebugger enter

    [author:]

        Claus Gittinger

"

! !

!MiniDebugger class methodsFor:'instance creation'!

enter

    "enter a miniDebugger"

    ^ self 

        enter:thisContext sender 

        withMessage:'MiniDebugger' 

        mayProceed:true

!

enter:aContext withMessage:aString mayProceed:mayProceed

    "enter a miniDebugger"

    |active con sender|

    StepInterruptPending := nil.

    Error 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:[

		    sender := con sender.

		    (sender notNil and:[sender selector == con selector]) ifTrue:[

			' ......: ' print. sender printString printCR.

			' ......:  [** intermediate recursive contexts skipped **]' printCR.

			[sender notNil

			 and:[sender selector == con selector

			 and:[sender method == con method]]] whileTrue:[

			    con := sender.

			    sender := con sender.

			].

		    ].

		    con := sender.

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

		]

	    ]

	].

    ].

    OperatingSystem hasConsole ifFalse:[

	Error handle:[:ex |

	    ex return

	] do:[

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

	].

	Error handle:[:ex |

	    'cannot raise Abort - exiting ...' errorPrintCR.

	    Smalltalk exit.

	] do:[

	    AbortOperationRequest raise.

	]

    ] ifTrue:[

	self new enter:aContext mayProceed:mayProceed.

    ].

    mayProceed ifFalse:[

	AbortOperationRequest raise

    ].

    ^ nil

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

!

enterException:ex

    "enter a debugger; if this is a recursive invocation, enter

     a MiniDebugger instead.

     This is the standard way of entering the debugger;

     sent from error- and halt messages."

    ^ self

        enter:ex returnableSuspendedContext

        withMessage:ex descriptionForDebugger

        mayProceed:(ex mayProceed).

!

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 isNil ifTrue:[

"/        TheOneAndOnlyDebugger := self basicNew initialize

"/    ].

"/    ^ TheOneAndOnlyDebugger

    "

     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:'entering'!

enter:aContext mayProceed:mayProceed

    "regular entry, via unhandled exception"

    |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:[

        AbortOperationRequest handle:[:ex |

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

        ] do:[

            Error handle:[:ex |

                'Error while executing MiniDebugger command: ' print.

                ex description printCR.

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

                yesNo == $d ifTrue:[

                    MiniDebugger enterWithMessage:'Debugging debugger' mayProceed:true.

                    ex proceed

                ].

                yesNo == $p ifTrue:[

                    ex proceed

                ].

                yesNo == $b ifTrue:[

                    ex suspendedContext fullPrintAll.

                    ex proceed

                ].

            ] do:[

                [

                    leaveCmd := self commandLoop.

                ] valueUnpreemptively.

            ].

        ].

        (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 (comment): / 29-09-2011 / 09:05:57 / cg"

!

stepInterrupt

    "entry via single 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-05-1996 / 10:23:11 / cg"

    "Modified (comment): / 29-09-2011 / 09:06:29 / cg"

! !

!MiniDebugger methodsFor:'initialization'!

initialize

    traceBlock := nil.

    tracing := false.

    stepping := false

! !

!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

!

garbageCollectCommand:id

    id == 3 ifTrue:[

	ObjectMemory reclaimSymbols.

	ObjectMemory compressOldSpace.

    ] ifFalse:[

	id == 2 ifTrue:[

	    ObjectMemory reclaimSymbols.

	] ifFalse:[

	    ObjectMemory garbageCollect.

	]

    ]

!

getContext

    |backtrace|

    backtrace := thisContext.

    (backtrace notNil) ifTrue: [

        [backtrace selector ~~ #commandLoop] whileTrue:[

            backtrace := backtrace sender.

        ].

        "remove Debugger commandLoop frame"

        backtrace := backtrace sender.

        "remove Debugger enter frame"

        backtrace := backtrace sender

    ].

    ^ backtrace

    "Modified: / 29-09-2011 / 09:00:14 / cg"

!

moveDotDown

    "/ sigh - must search

    |c|

    c := enteringContext.

    [ c notNil and:[ c sender ~~ dot ] ] whileTrue:[

	c := c sender.

    ].

    c notNil ifTrue:[

	dot := c.

	dot fullPrint.

    ] ifFalse:[

	'** dot is the bottom of the calling chain' printCR.

    ].

!

moveDotUp

    dot sender notNil ifTrue:[

	dot := dot sender.

	dot fullPrint.

    ] ifFalse:[

	'** dot is the top of the calling chain' printCR.

    ].

!

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

	    ]

	]

    ]

!

printDot

    dot fullPrint.

    'receiver: ' print. dot receiver printCR.

    'selector: ' print. dot selector printCR.

    'args: ' printCR.

    dot args keysAndValuesDo:[:idx :eachArg |

	'  ' print. idx print. ': ' print. eachArg printCR.

    ].

    'vars: ' printCR.

    dot vars keysAndValuesDo:[:idx :eachVar |

	'  ' print. idx print. ': ' print. eachVar printCR.

    ].

!

printDotsMethodSource

    |home mthd src|

    home := dot methodHome.

    mthd := home method.

    mthd isNil ifTrue:[

	'** no source **' printCR.

	^ self.

    ].

    src := mthd source.

    src isNil ifTrue:[

	'** no source **' printCR.

	^ self.

    ].

    src := src asCollectionOfLines.

    src keysAndValuesDo:[:lNr :line |

	lNr == dot lineNumber ifTrue:[

	    '>> ' print.

	] ifFalse:[

	    '   ' print.

	].

	line printCR.

    ]

!

stepping

    traceBlock := nil.

    tracing := false.

    stepping := true

!

tracingWith:aBlockOrNil

    traceBlock := aBlockOrNil.

    stepping := false.