'From Squeak3.1alpha of 6 February 2001 [latest update: #4173] on 18 August 2001 at 11:46:29 am'! "Change Set: BetterDebugger3 Date: 29 July 2001 Author: Hans-Martin Mosner Some more additions to the debugger: 1. Support for stepping into blocks (thanks to Henrik Gedenryd) 2. A NonBooleanReceiver exception 3. Balloon help for the debugger buttons 4. A problem with handling exceptions in the debugger was fixed (when you stepped into the exception handling code, and then did a step which executed the #signal method, it would open a separate notifier) Handling of #mustBeBoolean in code being debugged is still a bit rough... "! Error subclass: #NonBooleanReceiver instanceVariableNames: 'object ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'! !Object methodsFor: 'converting' stamp: 'hmm 7/29/2001 21:35'! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the interpreter. The sending context is rewound to just before the jump causing this exception." | proceedValue | thisContext sender skipBackBeforeJump. proceedValue _ NonBooleanReceiver new object: self; signal: 'proceed for truth.'. ^proceedValue ~~ false! ! !Debugger methodsFor: 'initialize' stamp: 'hmm 7/30/2001 17:25'! buildMVCOptionalButtonsButtonsView | aView bHeight offset aButtonView wid pairs windowWidth previousView | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 150. aView window: (0@0 extent: windowWidth@bHeight). offset _ 0. pairs _ self optionalButtonPairs. previousView _ nil. pairs do: [:pair | aButtonView _ PluggableButtonView on: self getState: nil action: pair second. pair second = pairs last second ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ windowWidth // (pairs size)]. aButtonView label: pair first asParagraph; insideColor: Color red muchLighter lighter; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. pair second = pairs first second ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'hmm 7/30/2001 17:29'! optionalButtonPairs "Actually, return tuples" ^ #(('Proceed' proceed 'close the debugger and procced.') ('Restart' restart 'reset this context to its start.') ('Send' send 'step into message sends') ('Step' doStep 'step over message sends') ('Through' stepIntoBlock 'step into a block') ('Full Stack' fullStack 'show full stack') ('Where' where 'select current pc range') ('Browse' browseMethodFull 'open a browser on the selected method'))! ! !Debugger methodsFor: 'initialize' stamp: 'hmm 7/30/2001 17:25'! optionalButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | aRow aButton | aRow _ AlignmentMorph newRow beSticky. aRow setNameTo: 'buttonPane'. aRow clipSubmorphs: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonPairs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; label: tuple first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 17:22'! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 12 14 17 20) selections: #(fullStack restart proceed doStep stepInto send where peelToFirst browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 20:49'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext. self contextStackIndex > 1 ifTrue: [newContext _ currentContext completeCallee: contextStackTop. self resetContext: newContext] ifFalse: [newContext _ currentContext stepToSendOrReturn. newContext == currentContext ifTrue: [newContext _ currentContext quickStep]. newContext == currentContext ifTrue: [ currentContext stepToSendOrReturn. self changed: #contentsSelection. self updateInspectors] ifFalse: [ externalInterrupt ifFalse: [newContext push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" newContext stepToSendOrReturn. self resetContext: newContext]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/29/2001 21:20'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Changed to just reset the context without resuming - hmm 7/29/2001 21:20" self okToChange ifFalse: [^ self]. self checkContextSelection. (self selectedContext isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: self selectedContext home] ifFalse: [^self]]. self selectedContext restart. self resetContext: self selectedContext! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 18:09'! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext.. self contextStackIndex > 1 ifTrue: [currentContext completeCallee: contextStackTop. self resetContext: currentContext] ifFalse: [newContext _ currentContext stepToSendOrReturn. newContext == currentContext ifTrue: [ newContext _ newContext step stepToSendOrReturn]. self resetContext: newContext]! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 17:56'! stepIntoBlock "Send messages until you return to the present method context. Used to step into a block in the method." | startContext ctxt | startContext _ self selectedContext home. self send. "check if nothing happend on send, otherwise continue until block" ctxt _ contextStackTop. [ctxt home ~= startContext and: [ctxt hasSender: startContext]] whileTrue: [ctxt _ ctxt step]. ctxt _ ctxt stepToSendOrReturn. self resetContext: ctxt! ! !Debugger class methodsFor: 'class initialization' stamp: 'hmm 7/29/2001 21:54'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #doStep; at: $T put: #stepInto; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !Debugger class methodsFor: 'instance creation' stamp: 'hmm 7/30/2001 21:02'! informExistingDebugger: aContext label: aString "Walking the context chain, we try to find out if we're in a debugger stepping situation. If we find the relevant contexts, we must rearrange them so they look just like they would if the methods were excuted outside of the debugger." | ctx quickStepMethod oldSender baseContext | ctx _ thisContext. quickStepMethod _ ContextPart compiledMethodAt: #quickSend:to:with:super:. [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx _ ctx sender]. baseContext _ ctx. "baseContext is now the context created by the #quickSend... method." oldSender _ ctx _ ctx sender home sender. "oldSender is the context which originally sent the #quickSend... method" [ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx _ ctx sender]. "ctx is the context of the Debugger method #doStep" ctx receiver labelString: aString. ctx receiver externalInterrupt: false; proceedValue: aContext receiver. baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" thisContext swapSender: oldSender. "make myself return to debugger" ErrorRecursion _ false. ^aContext! ! !Inspector methodsFor: 'accessing' stamp: 'hmm 7/29/2001 20:54'! object: anObject "Set anObject to be the object being inspected by the receiver." | oldIndex | anObject == object ifTrue: [self update] ifFalse: [oldIndex _ selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0]. self inspect: anObject. oldIndex _ oldIndex min: self fieldList size. self changed: #inspectObject. oldIndex > 0 ifTrue: [self toggleIndex: oldIndex] ifFalse: [self changed: #fieldList. self changed: #contents]]! ! !InstructionStream methodsFor: 'scanning' stamp: 'hmm 7/29/2001 21:25'! skipBackBeforeJump "Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction." | strm short | strm _ InstructionStream on: self method. (strm scanFor: [:byte | ((short _ byte between: 152 and: 159) or: [byte between: 168 and: 175]) and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??']. self jump: (short ifTrue: [-1] ifFalse: [-2]). ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/30/2001 20:40'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool _ self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBoolean to: bool with: #() super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current ctxt1 | ctxt _ aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current _ ctxt. ctxt1 _ ctxt quickStep. ctxt1 ifNil: [self halt]. ctxt _ ctxt1]. ^self stepToSendOrReturn! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend | self willReturn | self willStore] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !BlockContext methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 18:03'! stepToSendOrReturn pc = startpc ifTrue: [ "pop args first" self numArgs timesRepeat: [self step]]. ^super stepToSendOrReturn! ! !MethodContext methodsFor: 'initialize-release' stamp: 'hmm 7/29/2001 21:18'! restart "Reinitialize the receiver so that it is in the state it was at its creation." pc _ method initialPC. self stackp: method numTemps. method numArgs+1 to: method numTemps do: [:i | self tempAt: i put: nil]! ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object ^object! ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object: anObject object _ anObject! ! !NonBooleanReceiver methodsFor: 'signaledException' stamp: 'hmm 7/29/2001 21:37'! isResumable ^true! ! Debugger initialize! !Debugger class reorganize! ('class initialization' initialize openContext:label:contents:) ('instance creation' context: context:isolationHead: informExistingDebugger:label:) ('opening' openInterrupt:onProcess:) ! Debugger removeSelector: #restart:!