"

 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' }"

"{ NameSpace: Smalltalk }"

Object subclass:#MiniDebugger

	instanceVariableNames:'tracing stepping traceBlock command commandArg commandCount

		enteringContext dot nesting inputStream'

	classVariableNames:'NotFirstTimeEntered'

	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 or the UI/event handler is broken).

    This one is also called for, if an interrupt occurs within the debuger, 

    or if CTRL-C is pressed in the controlling tty/console.

    Needs a console.

        MiniDebugger enter

    Attention:

        all printing is done via lowLevel _errorPrint messages,

        to ensure that output is to stderr, even if a logger is present, 

        or Stderr has been set to some other stream (Transcript).

        Also to avoid the logger's interfering and adding imestamp information.

    [author:]

        Claus Gittinger

"

! !

!MiniDebugger class methodsFor:'instance creation'!

enter

    "enter a miniDebugger"

    ^ self

        enter:thisContext sender

        withMessage:'MiniDebugger'

        mayProceed:true

        input:nil

    "

     MiniDebugger enter

    "

!

enter:aContext withMessage:aString mayProceed:mayProceed

    "enter a miniDebugger"

    ^ self 

        enter:aContext 

        withMessage:aString 

        mayProceed:mayProceed 

        input:nil

!

enter:aContext withMessage:aString mayProceed:mayProceed input:inputStreamOrNil

    "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 _errorPrintCR.

        Processor notNil ifTrue:[

            active := Processor activeProcess.

            'process: id=' _errorPrint. active id _errorPrint.

            ' name=' _errorPrint. active name _errorPrintCR.

            'context: ' _errorPrint. aContext printString _errorPrintCR.

            (con := aContext) notNil ifTrue:[

                con := con sender.

                ' ......: ' _errorPrint. con printString _errorPrintCR.

                [con notNil] whileTrue:[

                    sender := con sender.

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

                        ' ......: ' _errorPrint. sender printString _errorPrintCR.

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

                        [sender notNil

                         and:[sender selector == con selector

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

                            con := sender.

                            sender := con sender.

                        ].

                    ].

                    con := sender.

                    ' ......: ' _errorPrint. con printString _errorPrintCR.

                ]

            ]

        ].

        NotFirstTimeEntered ~~ true ifTrue:[

            NotFirstTimeEntered := true.

        ].

    ].

    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.

            OperatingSystem exit:10.

        ] do:[

            AbortOperationRequest raise.

        ]

    ] ifTrue:[

        self new 

            inputStream:inputStreamOrNil;

            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 creator name,': ',ex descriptionForDebugger)

        mayProceed:(ex mayProceed)

        input:nil

!

enterWithMessage:aString mayProceed:mayProceed

    "enter a miniDebugger"

    ^ self

        enter:thisContext sender

        withMessage:aString

        mayProceed:mayProceed

        input:nil

    "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

        input:nil

    "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 _errorPrintCR]

    "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:'accessing'!

inputStream:aStream

    "if non-nil, the debugger will read its input from there.

     This allows for a miniDebugger to be used in a telnet stream (scripting)"

    inputStream := aStream.

! !

!MiniDebugger methodsFor:'entering'!

enter:aContext mayProceed:mayProceed

    "regular entry, via unhandled exception"

    |c leaveCmd stillHere yesNo|

    Display notNil ifTrue:[

        Display ungrabKeyboard; ungrabPointer.

    ].

    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 caught - back in previous debugLevel' _errorPrintCR.

        ] do:[

            Error handle:[:ex |

                StreamError handle:[:ex|

                    "You won't see this probably - but you will see it when doing a syscall trace"

                    'Error while processing _error in MiniDebugger (Stdout closed?):' _errorPrintCR.

                    ex description _errorPrintCR.

                    OperatingSystem exit:10.

                ] do:[

                    'Error while executing MiniDebugger command: ' _errorPrint.

                    ex description _errorPrintCR.

                    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 | self printContext:where].

            ObjectMemory flushInlineCaches.

            ObjectMemory stepInterruptHandler:self.

            stillHere := false.

            StepInterruptPending := 1.

            InterruptPending := 1

        ].

        (leaveCmd == $c) ifTrue: [

            traceBlock := nil.

            ObjectMemory flushInlineCaches.

            ObjectMemory stepInterruptHandler:nil.

            stillHere := false.

            stepping := false.

            tracing := false.

            StepInterruptPending := nil.

            InterruptPending := nil

        ].

        ((leaveCmd == $a) or:[(leaveCmd == $Y)]) ifTrue: [

            "abort"

            traceBlock := nil.

            ObjectMemory flushInlineCaches.

            ObjectMemory stepInterruptHandler:nil.

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

            self printContext:where

        ] 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.

	]

    ]

!

getCharacter

    inputStream isNil ifTrue:[

        "/ globally blocking

        ^ Character fromUser

    ].

    ^ inputStream next

!

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' _errorPrintCR.

    ].

!

moveDotUp

    |sender|

    (sender := dot sender) notNil ifTrue:[

        dot := sender.

        "/ dot fullPrint.

    ] ifFalse:[

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