"
 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.
    tracing := true
! !

!MiniDebugger methodsFor:'user commands'!

commandLoop
    "read-eval commands, until one of the continue, abort or single step commands is entered; 
     return the last command character"

    |cmd done|

    done := false.
    [done] whileFalse:[
        cmd := self getCommand:nil.
        cmd isNil ifTrue:[   "/ EOF is treated like continue command
            cmd := $c
        ].
        done := self doCommand:cmd.
    ].
    ^ cmd

    "Modified (comment): / 29-09-2011 / 09:02:24 / cg"
!

doAbort
    |con sig|

    (sig := AbortOperationRequest) isHandled ifTrue:[
	sig raise.
	'abort raise failed' errorPrintCR.
    ].

    "TEMPORARY kludge - find event handler context
     this will be removed, once real debugging is possible
    "
    con := self findContext:#processEvent.
    con isNil ifTrue:[
	con := self findContext:#dispatch.
    ].
    con notNil ifTrue:[
	"got it"
	con return.
	'return failed' errorPrintCR.
    ].

    'found no context to resume' errorPrintCR.

    "Modified: / 16.11.2001 / 17:39:14 / cg"
!

doCommand:cmd
    "a single command; return true, if command loop should be finished"

    |id proc|

    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:[
        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:[
                '-------- walkback of current process -------' printCR.
                self printBacktraceFrom:(self getContext)
            ]
        ].
        ^ false
    ].

    (cmd == $b) ifTrue:[
        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
            ]
        ].
        ^ false
    ].

    (cmd == $S) ifTrue:[
        'saving "crash.img"...' print.
        ObjectMemory writeCrashImage.
        'done.' printCR.
        ^ false
    ].

    (cmd == $B) ifTrue:[
        self printAllBacktraces.
        ^ false
    ].

    (cmd == $P) ifTrue:[
        self showProcesses.
        ^ false
    ].

    (cmd == $r) ifTrue:[
        dot receiver printCR.
        ^ false
    ].

    (cmd == $i) ifTrue:[
        MiniInspector openOn:(dot receiver).
        ^ false
    ].

    (cmd == $I) ifTrue:[
        self interpreterLoopWith:nil.
        ^ false
    ].
    (cmd == $e) ifTrue:[
        Parser evaluate:commandArg.
        ^ false
    ].

    (cmd == $c) ifTrue:[^ true].
    (cmd == $s) ifTrue:[^ true].
    (cmd == $t) ifTrue:[^ true].
    (cmd == $a) ifTrue:[^ true].

    (cmd == $u) ifTrue:[
        stepping := false.
        tracing := false.
        Processor activeProcess vmTrace:false.
        ^ false
    ].

    (cmd == $R) ifTrue:[
        proc notNil ifTrue:[
            proc resume.
        ].
        ^ false
    ].

    (cmd == $T) ifTrue:[
        proc notNil ifTrue:[
            proc terminate.
        ] ifFalse:[
            id notNil ifTrue:[
                'no process with id: ' print. id printCR.
            ] ifFalse:[
                Processor terminateActive
            ]
        ].
        ^ false
    ].

    (cmd == $W) ifTrue:[
        proc notNil ifTrue:[
            'stopping process id: ' print. id printCR.
            proc stop.
        ] ifFalse:[
            'invalid process id: ' print. id printCR.
        ].
        ^ false
    ].

    (cmd == $a) ifTrue:[
        "without id-arg, this is handled by caller"
        proc notNil ifTrue:[
            'aborting process id: ' print. id printCR.
            proc interruptWith:[AbortOperationRequest raise]
        ] ifFalse:[
            'aborting' printCR.
        ].
        ^ false
    ].

    (cmd == $Q) ifTrue:[
        proc notNil ifTrue:[
            proc terminateNoSignal.
        ] ifFalse:[
            id notNil ifTrue:[
                'no process with id: ' print. id printCR.
            ] ifFalse:[
                Processor terminateActiveNoSignal
            ]
        ].
        ^ false
    ].

    (cmd == $g) ifTrue:[
        self garbageCollectCommand:id.
        ^ false
    ].

    (cmd == $U) ifTrue:[
        MessageTracer unwrapAllMethods.
        ^ false
    ].
    (cmd == $X) ifTrue:[
        Smalltalk fatalAbort.
        "/ not reached
        ^ false
    ].
    (cmd == $x) ifTrue:[
        OperatingSystem exit.
        "/ not reached
        ^ false
    ].

    (cmd == $.) ifTrue:[self printDot. ^ false ].
    (cmd == $m) ifTrue:[self printDotsMethodSource. ^ false ].
    (cmd == $-) ifTrue:[self moveDotUp. ^ false ].
    (cmd == $+) ifTrue:[self moveDotDown. ^ false ].

    "/ avoid usage print if return was typed ...
    ((cmd == Character return)
    or:[cmd == Character linefeed]) ifTrue:[^ false].

    self showValidCommandHelp.
    ^ false.

    "Modified: / 29-09-2006 / 12:23:18 / cg"
    "Created: / 29-09-2011 / 08:58:47 / cg"
!

getCommand:prompt
"/    Screen notNil ifTrue:[
"/        Screen allScreens do:[:aScreen |
"/            aScreen ungrabPointer.
"/            aScreen ungrabKeyboard.
"/        ].
"/    ].

    Display notNil ifTrue:[
        Display ungrabPointer.
        Display ungrabKeyboard.
    ].

    (prompt
        ? (nesting == 0 ifTrue:[
            'MiniDebugger> '
          ] ifFalse:[
            'MiniDebugger' , nesting printString , '>'
          ])) print.

    UserInterrupt handle:[:ex |
        ex restart
    ] do:[
        |c cmd arg cnt|

        cmd := Character fromUser.
        cmd isNil ifTrue:[
            "
             mhmh end-of-file;
             return a 'c' (for continue); hope thats ok.
            "
            cmd := $c
        ].

        cnt := nil.
        (cmd isDigit) ifTrue:[
            cnt := 0.
            [cmd isDigit] whileTrue:[
                cnt := (cnt * 10) + cmd digitValue.
                cmd := Character fromUser
            ].
            [cmd == Character space] whileTrue:[
                cmd := Character fromUser
            ].
        ].

        "
         collect to end-of-line in arg
        "
        c := cmd.
        arg := ''.
        [c isNil or:[c isEndOfLineCharacter]] whileFalse: [
            arg := arg copyWith:c.
            c := Character fromUser.
        ].
        commandArg := arg copyFrom:2.
        command := cmd.
        commandCount := cnt.
    ].
    ^ command

    "Modified: / 31.7.1998 / 16:11:01 / cg"
!

interpreterLoopWith:anObject
    'read-eval-print loop; exit with "#exit"; help with "?"' printCR.
    (ReadEvalPrintLoop new doChunkFormat:false; error:Stderr; prompt:'> ')readEvalPrintLoop.

"/    |line done rslt|
"/
"/    'read-eval-print loop; exit with empty line' printCR.
"/    '' printCR.
"/
"/    done := false.
"/    [done] whileFalse:[
"/        '> ' print.
"/
"/        line := Stdin nextLine.
"/        (line size == 0) ifTrue:[
"/            done := true
"/        ] ifFalse:[
"/            "/ rslt := Compiler evaluate:line
"/            "/                  receiver:anObject
"/            "/                  notifying:nil.
"/
"/            rslt := Compiler
"/                evaluate:line
"/                in:dot
"/                receiver:dot receiver
"/                notifying:self "/ nil
"/                ifFail:[].
"/            rslt printCR.
"/        ]
"/    ]

    "Modified: / 31.7.1998 / 16:01:47 / cg"
!

printAllBacktraces
    Process allInstancesDo:[:p |
        (p isActive not
        and:[p isDead not]) ifTrue:[
            '---------------------------------------------------------' printCR.
            '  proc id=' print. p id print.
            ' name=''' print. p name print.
            ''' createdBy: ' print. p creatorId print.
            ' state=' print.  p state print.
            ' prio=' print. p priority printCR.
            '' printCR. '' printCR.

            self printBacktraceFrom:(p suspendedContext)
        ]
    ]
!

showProcesses
    |active|

    active := Processor activeProcess.
    'current id=' print. active id print. ' name=''' print. active name print. '''' printCR.

    Process allSubInstancesDo:[:p |
	'proc id=' print. (p id printStringPaddedTo:5) print.
	(p state printStringPaddedTo:10) print.
	' pri=' print. (p priority printStringPaddedTo:2) print.
	' creator:' print. (p creatorId printStringPaddedTo:5) print.
	' name=''' print. p name print.
	'''' printCR.
    ]

    "Modified: / 31.7.1998 / 16:30:19 / cg"
!

showValidCommandHelp
        'valid commands:
   c ..... continue
   s ..... step
   t ..... trace (continue with trace)
   a [id]. abort (i.e. raise abort signal) in (current) process
   T [id]. terminate (current) process
   W [id]. stop (current) process
   R [id]. resume (current) process
   Q [id]. quick terminate (current) process - no unwinds or cleanup

   P ..... list processes
   l [id]. print context chain (of process with id)
   b [id]. full (VM) backtrace
   B ..... backtrace of all other processes

   U ..... unwrap all traced/breakpointed methods
   g ..... collect all garbage
   g 2.... collect all garbage & reclaim symbols
   g 3.... collect all garbage, reclaim symbols and compress

   S ..... save snapshot into crash.img
   x ..... exit Smalltalk
   X ..... exit Smalltalk (+core dump)

   . ..... print dot (the current context)
   m ..... print dots method source code
   - ..... move dot up (sender)
   + ..... move dot down (called context)

   r ..... receiver (in dot) printString
   i ..... inspect receiver (in dot)
   I ..... interpreter (expression evaluator)
   e expr  evaluate expression

   To repair a broken X-Connection, enter an interpreter and evaluate:
      Display := XWorkstation new.
      Display initializeFor:''hostName:0''.
      Display startDispatch.
      NewLauncher openOnDevice:Display.
      <empty line>
   then enter ''c'' to continue; a NewLauncher should pop up soon.

'  errorPrintCR
! !

!MiniDebugger class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.79 2011-09-29 07:06:51 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.79 2011-09-29 07:06:51 cg Exp $'
! !