"

 COPYRIGHT (c) 1989 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:libtool' }"

StandardSystemView subclass:#DebugView

	instanceVariableNames:'busy haveControl exitAction canContinue contextView codeView

		receiverInspector contextInspector contextArray selectedContext

		catchBlock grabber mayProceed traceView tracing bigStep

		skipLineNr steppedContextAddress abortButton terminateButton

		continueButton stepButton nextButton nextOverButton nextOutButton

		sendButton returnButton restartButton exclusive inspecting

		nChainShown inspectedProcess updateProcess stopButton

		updateButton defineButton monitorToggle stepping

		steppedContextLineno stepForReturn actualContext inWrap

		stackInspector steppedContext wrapperContext verboseBacktrace

		firstContext stepHow cachable currentMethod ignoreBreakpoints

		stepUntilEntering lastStepUntilEntering

		lastSelectionInReceiverInspector lastSelectionInContextInspector

		canShowMore exitAbort reportButton setOfHiddenCallingSelectors'

	classVariableNames:'CachedDebugger CachedExclusive OpenDebuggers MoreDebuggingDetail

		DefaultDebuggerBackgroundColor InitialNCHAINShown'

	poolDictionaries:''

	category:'Interface-Debugger'

!

!DebugView class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1989 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

"

    This class implements a graphical debugger interface.

    The debugger usually sits on top of the faulting process,

    taking over its event processing. 

    (this is different from other Smalltalk debuggers, which control

     the debuggee as a separate process. Consider this an historic

     leftover - the debugger was one of the first applications written for

     ST/X; however, why should we change it without a particular need ...).

    Only the 'stopped' debugged process is affected;

    other processes continue to respond to events.

    The one exception is when an error occurs within the dispatcher process

    or in one of the eventhandler processes - in this case, the debugger

    will sit on an exclusive display connection.

    The whole debugging will be changed, once the required process primitives

    are available, which allow control of another processes execution

    (i.e. single-step, restart & return). The setup will be changed then,

    to have the debugger control the debuggee (i.e. two processes)

    See additional information in 'doc/misc/debugger.doc'.

    Notice: the DebugView class caches the last used debugger in a class

    variable. It may happen, that a malfunctioning debugger (for example,

    a halfway destroyed one) is kept there. You will notice this, if a

    debugger comes up without showing any contents. In this case, close

    (or destroy) the broken debugView, and execute

        Debugger newDebugger

    which removes the cached debugger and forces creation of a new one the

    next time. This is a temporary workaround - the debugger will be fixed to

    avoid this problem.

    [author:]

        Claus Gittinger

    [see also:]

        Exception Signal

        Process

"

! !

!DebugView class methodsFor:'initialization'!

initialize

    InitialNCHAINShown := 20.

    "/ DefaultDebuggerBackgroundColor := Color red lightened.

    "/ DefaultDebuggerBackgroundColor := Color blue lightened lightened.

    "Created: 20.3.1997 / 16:53:37 / cg"

    "Modified: 20.3.1997 / 16:54:32 / cg"

!

reinitialize

    self newDebugger

! !

!DebugView class methodsFor:'instance creation'!

enter

    "enter a debugger"

    <context: #return>

    self enter:thisContext sender withMessage:'debugger entered' mayProceed:true.

!

enter:aContext withMessage:aString 

    "enter a debugger"

    <context: #return>

    ^ self

        enter:aContext 

        withMessage:aString 

        mayProceed:true

!

enter:aContext withMessage:aString mayProceed:mayProceed

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

    <context: #return>

    |active|

    StepInterruptPending := nil.

    ControlInterrupt handle:[:ex |

        'DebugView [info]: breakpoint in debugger setup ignored [enter.]' infoPrintCR.

        ('DebugView [info]: breakpoint on:' , ex suspendedContext printString) infoPrintCR.

        ex proceed

    ] do:[

        "

         well, it could be a stepping or sending debugger up there;

         in this case, return to it. This happens, when a stepping process

         runs into an error (for example, a halt). In this case, we want the

         stepping debugger to come up again instead of a new one.

        "

        OpenDebuggers notNil ifTrue:[

            active := Processor activeProcess.

            OpenDebuggers do:[:aDebugger |

                (aDebugger inspectedProcess == active) ifTrue:[

                    aDebugger device isOpen ifTrue:[

                        "/ 'entering stepping debugger again' printNL.

                        aDebugger unstep.

                        aDebugger setLabelFor:aString in:active.

                        aDebugger mayProceed:mayProceed.

                        ^ aDebugger enter:aContext select:nil.

                    ]

                ]

            ]

        ].

    ].

    ^ self enterUnconditional:aContext withMessage:aString mayProceed:mayProceed

    "Modified: / 18.11.2001 / 00:48:03 / cg"

!

enterUnconditional:aContext withMessage:aString mayProceed:mayProceed

    "enter a debugger - do not check for recursive invocation"

    <context: #return>

    |aDebugger|

    StepInterruptPending := nil.

    "/ ignore halts & breakpoints while setting up the debugger

    "/ to avoid recursive debugging ...

    ControlInterrupt handle:[:ex |

        'DebugView [info]: breakpoint in debugger setup ignored [enterUncond.]' infoPrintCR.

        ('DebugView [info]: breakpoint on:' , ex suspendedContext printString) infoPrintCR.

        ex proceed

    ] do:[

        aDebugger := self new.

    ].

    aDebugger isNil ifTrue:[

        'DebugView [error]: cannot open debugger' errorPrintCR.

        'DebugView [error]: Exception: ' errorPrint. aString errorPrintCR.

        mayProceed ifTrue:[

            (Dialog confirm:'Error/Breakpoint cought.\\Press Continue or Abort.' withCRs

                   yesLabel:'Continue' noLabel:'Abort')

            ifTrue:[

                ^ nil

            ].

        ] ifFalse:[

            self information:'Error cought.\\Press OK to abort the operation.' withCRs.

        ].

        AbortOperationRequest raise.

        "not reached"

    ].

    aDebugger mayProceed:mayProceed.

    aDebugger setLabelFor:aString in:Processor activeProcess.

    aDebugger enter:aContext select:nil.

    ^ nil.

    "

        nil halt

    "

    "Modified: / 18.11.2001 / 00:29:23 / cg"

!

enterWithMessage:message

    "enter a debugger"

    <context: #return>

    self enter:(thisContext sender) withMessage:message mayProceed:true.

!

new

    "return a new DebugView. 

     - return a cached debugger if it already exists.

     Also, care for remote displays on which no debugger is wanted

     (ask with mayOpenDebugger) - if so, open on the default screen."

    |debugger currentScreen debuggerDevice|

    currentScreen := Screen current.

    currentScreen notNil ifTrue:[

        (currentScreen suppressDebugger) ifTrue:[

            "/ no debuggers with that device - show an alertBox which aborts...

            ^ nil.

        ].

        (currentScreen mayOpenDebugger) ifFalse:[

            "/ no debugger on that device - but on the main screen

            currentScreen := Screen default.

        ].

    ].

    "

     need a blocking debugger if no processes or 

     or if its a timing/interrupt process 

     (because otherwise we would not get any events here ...

    "

    Processor activeProcessIsSystemProcess ifTrue:[

        ((debugger := CachedExclusive) isNil 

        or:[debugger device ~~ currentScreen

        or:[currentScreen isNil

        or:[currentScreen isOpen not]]]) ifTrue:[

            debugger := self newExclusive

        ].

        CachedExclusive := nil.

    ] ifFalse:[

        CachedDebugger notNil ifTrue:[

            (CachedDebugger device ~~ currentScreen 

            or:[currentScreen isNil

            or:[currentScreen isOpen not]]) ifTrue:[

                CachedDebugger := nil

            ]

        ].

        (debugger := CachedDebugger) notNil ifTrue:[

            CachedDebugger := nil.

        ] ifFalse:[

            debuggerDevice := currentScreen.

            debuggerDevice isNil ifTrue:[

                "/ use the default display

                debuggerDevice := Screen default.

            ].

            (debuggerDevice isNil

            or:[debuggerDevice isOpen not

            "/ or:[debuggerDevice mayOpenDebugger not]

            ]) ifTrue:[

                "/ no debugger

                ^ nil.

            ].

            Screen currentScreenQuerySignal answer:debuggerDevice

            do:[

                debugger := super new.

            ].

            debugger label:'Debugger'.

            debugger icon:self defaultIcon.

        ]

    ].

    ^ debugger

    "Modified: 31.7.1997 / 21:20:27 / cg"

!

newExclusive

    "return a debugger for exclusive display access"

    |debugger|

    debugger := super new.

    debugger label:'Debugger'.

    debugger icon:self defaultIcon.

    debugger exclusive:true.

    ^ debugger

    "Modified: 1.1.1970 / 23:27:06 / cg"

!

openOn:aProcess

    "start a  debugger on aProcess

     (actually not more than a good-looking inspector)"

    |aDebugger label nm|

    aDebugger := super new.

    aDebugger icon:self defaultIcon.

    aProcess notNil ifTrue:[

        nm := aProcess name.

        nm notNil ifTrue:[

            nm := (nm contractTo:17) , '-' , aProcess id printString

        ] ifFalse:[

            nm := aProcess id printString

        ].

        label := 'Debugger [' , nm , ']'.

    ] ifFalse:[

        label := 'no process'

    ].

    aDebugger label:label iconLabel:'Debugger'.

    aDebugger openOn:aProcess.

    ^ nil

    "Modified: 4.4.1997 / 16:22:36 / cg"

! !

!DebugView class methodsFor:'cleanup'!

lowSpaceCleanup 

    "in low memory situations, give up cached debuggers"

    CachedDebugger := nil.

    CachedExclusive := nil.

    OpenDebuggers := nil.

    "

     DebugView lowSpaceCleanup

    "

    "Modified: 18.4.1996 / 16:48:03 / cg"

!

newDebugger

    "force creation of a new debugger (give up cached debuggers)"

    CachedDebugger := nil.

    CachedExclusive := nil.

    OpenDebuggers := nil.

    (Debugger isBehavior and:[Debugger name = #DebugView]) ifTrue:[

        Debugger := self

    ].

    "

     DebugView newDebugger

    "

! !

!DebugView class methodsFor:'defaults'!

defaultIcon

!

defaultVerboseBacktrace

    ^ VerboseBacktraceDefault

    "Created: 11.1.1997 / 12:14:35 / cg"

!

defaultVerboseBacktrace:aBoolean

    VerboseBacktraceDefault := aBoolean

    "Created: 11.1.1997 / 12:14:44 / cg"

!

updateStyleCache

    "extract values from the styleSheet and cache them in class variables"

    <resource: #style (#'debugView.viewBackgroundColor')>

    DefaultDebuggerBackgroundColor := StyleSheet at:#'debugView.viewBackgroundColor'

    "Modified: / 17.11.2001 / 17:31:42 / cg"

! !

!DebugView class methodsFor:'menu specs'!

menuSpec

    "This resource specification was automatically generated

     by the MenuEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,

     the MenuEditor may not be able to read the specification."

    "

     MenuEditor new openOnClass:DebugView andSelector:#menuSpec

     (Menu new fromLiteralArrayEncoding:(DebugView menuSpec)) startUp

    "

    <resource: #menu>

    ^ 

     #(Menu

        (

         (MenuItem

            label: 'View'

            translateLabel: true

            submenu: 

           (Menu

              (

               (MenuItem

                  enabled: canShowMore

                  label: 'Show more WalkBack'

                  itemValue: showMore

                  translateLabel: true

                )

               (MenuItem

                  label: 'Show verbose WalkBack'

                  itemValue: toggleVerboseWalkback

                  translateLabel: true

                  isVisible: showingDenseWalkback

                )

               (MenuItem

                  label: 'Show dense WalkBack'

                  itemValue: toggleVerboseWalkback

                  translateLabel: true

                  isVisible: showingVerboseWalkback

                )

               (MenuItem

                  label: '-'

                )

               (MenuItem

                  label: 'Exit'

                  itemValue: closeRequest

                  translateLabel: true

                  isVisible: isInspecting

                )

               (MenuItem

                  label: 'Close Debugger and Abort'

                  itemValue: closeRequest

                  translateLabel: true

                  isVisible: isNotInspecting

                )

               )

              nil

              nil

            )

          )

         (MenuItem

            label: 'Process'

            translateLabel: true

            submenu: 

           (Menu

              (

               (MenuItem

                  label: 'Continue'

                  itemValue: doContinue

                  translateLabel: true

                )

               (MenuItem

                  label: '-'

                )

               (MenuItem

                  label: 'Abort'

                  itemValue: doAbort

                  translateLabel: true

                )