"

 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'

       classVariableNames:   'TheOneAndOnlyDebugger'

       poolDictionaries:''

       category:'System-Debugging-Support'

!

MiniDebugger comment:'

COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.17 1995-08-30 14:07:38 claus Exp $

'!

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

"

!

version

"

$Header: /cvs/stx/stx/libbasic/MiniDebugger.st,v 1.17 1995-08-30 14:07:38 claus Exp $

"

!

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 class methodsFor: 'instance creation'!

new

    TheOneAndOnlyDebugger printNL.

    TheOneAndOnlyDebugger isNil ifTrue:[

	TheOneAndOnlyDebugger := self basicNew initialize

    ].

    ^ TheOneAndOnlyDebugger

!

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

!

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

!

enter

    ^ self enterWithMessage:'MiniDebugger'

!

enter:aContext

    ^ self enterWithMessage:'MiniDebugger'

!

enter:aContext withMessage:aString

    ^ self enterWithMessage:aString

!

enterWithMessage:aString

    |active|

    StepInterruptPending := nil.

    aString printNL.

    Processor notNil ifTrue:[

	active := Processor activeProcess.

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

    ].

    self new enter.

    ^ nil

! !

!MiniDebugger methodsFor: 'initialization'!

initialize

    traceBlock := nil.

    tracing := false.

    stepping := false

! !

!MiniDebugger methodsFor: 'private'!

stepping

    traceBlock := nil.

    tracing := false.

    stepping := true

!

tracingWith:aBlockOrNil

    traceBlock := aBlockOrNil.

    stepping := false.

    tracing := true

!

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

!

findContext:aSelector

    |con|

    con := thisContext sender.

    [con notNil] whileTrue:[

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

	    "got it"

	    ^ con

	].

	con := con sender

    ].

    ^ nil

! !

!MiniDebugger methodsFor: 'interrupt handling'!

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' errorPrintNewline

	].

	self enter

    ] ifFalse:[

	where notNil ifTrue:[

	    traceBlock notNil ifTrue:[

		traceBlock value:where

	    ]

	] ifFalse:[

	    'traceInterrupt: no context' errorPrintNewline

	].

	ObjectMemory flushInlineCaches.

	StepInterruptPending := 1.

	InterruptPending := 1

    ]

!

enter

    |leaveCmd stillHere|

    Display notNil ifTrue:[

	Display ungrabPointer.

	Display ungrabKeyboard.

    ].

    stillHere := true.

    [stillHere] whileTrue:[

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

	    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"

	].

    ].

    ^ nil

! !

!MiniDebugger methodsFor: 'user commands'!

doAbort

    |con sig|

    (sig := Object abortSignal) isHandled ifTrue:[

	sig raise.

	'abort raise failed' errorPrintNewline.

    ].

    "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' errorPrintNewline.

    ].

    'found no context to resume' errorPrintNewline.

!

showProcesses

    |active|

    active := Processor activeProcess.

    'current id=' print. active id print. ' name=' print. active name printNewline.

    Process allInstancesDo:[:p |

	'proc id=' print. p id print. ' name=' print. p name print. ' state=' print.

			  p state print. ' prio=' print. p priority printNL.

    ]

!

commandLoop

    |cmd done valid context|

    done := false.

    [done] whileFalse:[

	valid := false.

	cmd := self getCommand.

	(cmd == $p) ifTrue:[

	    valid := true.

	    context isNil ifTrue: [

		context := self getContext

	    ].

	    context notNil ifTrue:[

		context fullPrintAll

	    ] ifFalse:[

		'no context' errorPrintNewline

	    ]

	].

	(cmd == $P) ifTrue:[

	    valid := true.

	    self showProcesses.

	].

	(cmd == $r) ifTrue:[

	    valid := true.

	    context isNil ifTrue: [

		context := self getContext

	    ].

	    context notNil ifTrue:[

		"remove Debugger stepinterrupt/halt frame"

		context sender receiver printNewline

	    ] ifFalse:[

		'no context - dont know receiver' errorPrintNewline

	    ]

	].

	(cmd == $R) ifTrue:[

	    valid := true.

	    context isNil ifTrue: [

		context := self getContext

	    ].

	    context notNil ifTrue:[

		"remove Debugger stepinterrupt/halt frame"

		context sender receiver storeOn:Stdout

	    ] ifFalse:[

		'no context - dont know receiver' errorPrintNewline

	    ]

	].

	(cmd == $i) ifTrue:[

	    valid := true.

	    context isNil ifTrue: [

		context := self getContext

	    ].

	    context notNil ifTrue:[

		"remove Debugger stepinterrupt/halt frame"

		MiniInspector openOn:(context sender receiver)

	    ] ifFalse:[

		'no context - dont know receiver' errorPrintNewline

	    ]

	].

	(cmd == $I) ifTrue:[

	    valid := true.

	    context isNil ifTrue: [

		context := self getContext

	    ].

"/          context notNil ifTrue:[

"/              "remove Debugger stepinterrupt/halt frame"

"/              self interpreterLoopWith:(context sender receiver)

"/          ] ifFalse:[

"/              'no context - dont know receiver' errorPrintNewline.

		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 == $T) ifTrue:[valid := true. Processor terminateActive].

	(cmd == $Q) ifTrue:[valid := true. Processor terminateActiveNoSignal].

	(cmd == $U) ifTrue:[MessageTracer unwrapAllMethods].

	(cmd == $X) ifTrue:[Smalltalk fatalAbort].

	(cmd == $x) ifTrue:[OperatingSystem exit].

	valid ifFalse: [

	    'valid commands:

   (c)ontinue

   (s)tep

   (t)race (continue with trace)

   (p)rint context chain

   (r)eceiver printString

   (R)eceiver storeString

   (i)nspect (enter inspector on receiver)

   (I)nterpreter (expression evaluator)

   (a)bort (raise abort signal)

   (P)rocess list

   (T)terminate current process

   (Q)uick terminate current process (no unwinds)

   (U)nwrap all traced/breakpointed methods

   (X)exit (+core)

   (x)exit Smalltalk'  errorPrintNewline

	]

    ].

    ^ cmd

!

getCommand

    |cmd c|

    'MiniDebugger> ' print.

    Object userInterruptSignal handle:[:ex |

	ex restart

    ] do:[

	cmd := Character fromUser.

	cmd isNil ifTrue:[

	    "

	     mhmh end-of-file;

	     return a 'c' (for continue); hope thats ok.

	    "

	    cmd := $c

	].

	"

	 ignore to end-of-line

	"

	c := cmd.

	[c isNil or:[c isEndOfLineCharacter]] whileFalse: [

	    c := Character fromUser.

	].

    ].

    ^ cmd

!

interpreterLoopWith:anObject

    |line done|

    'read-eval-print loop; exit with empty line' printNewline.

    done := false.

    [done] whileFalse:[

	line := Stdin nextLine.

	(line size == 0) ifTrue:[

	    done := true

	] ifFalse:[

	    (Compiler evaluate:line 

		      receiver:anObject

		     notifying:nil) printNewline

	]

    ]

! !