SystemOrganization addCategory: #'OB-Debugger'! OBDefinition subclass: #ODContextDefinition instanceVariableNames: 'node context methodNode sourceMap' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODContextDefinition class methodsFor: 'instance-creation' stamp: 'lr 4/26/2007 10:00'! node: aNode ^ self basicNew initializeNode: aNode! ! !ODContextDefinition methodsFor: 'accessing' stamp: 'lr 4/25/2007 18:27'! context ^ context! ! !ODContextDefinition methodsFor: 'callbacks' stamp: 'lr 4/25/2007 18:28'! doItContext ^ self context! ! !ODContextDefinition methodsFor: 'callbacks' stamp: 'lr 4/25/2007 18:28'! doItReceiver ^ self context receiver! ! !ODContextDefinition methodsFor: 'initialization' stamp: 'lr 4/26/2007 10:11'! initializeNode: aNode node := aNode. context := aNode context. methodNode := context methodNode. sourceMap := methodNode sourceMap! ! !ODContextDefinition methodsFor: 'accessing' stamp: 'lr 4/25/2007 18:35'! methodNode ^ methodNode! ! !ODContextDefinition methodsFor: 'callbacks' stamp: 'lr 4/25/2007 18:41'! selection | pc index end | (self context isDead or: [ self sourceMap isEmpty ]) ifTrue: [ ^ super selection ]. " new compiler " Smalltalk at: #RBProgramNode ifPresent: [ :class | (self methodNode isKindOf: class) ifTrue: [ pc := self context pc. index := self sourceMap findLast: [ :range | range key <= pc ]. ^ index = 0 ifTrue: [ super selection ] ifFalse: [ (self sourceMap at: index) value ] ] ]. " old compiler " pc := self context pc - 1. index := self sourceMap indexForInserting: (Association key: pc value: nil). index < 1 ifTrue: [ ^ super selection ]. index > self sourceMap size ifTrue: [ end := self sourceMap inject: 0 into: [ :prev :this | prev max: this value last ]. ^ end + 1 to: end ]. ^ (self sourceMap at: index) value! ! !ODContextDefinition methodsFor: 'accessing' stamp: 'lr 4/25/2007 18:35'! sourceMap ^ sourceMap! ! !ODContextDefinition methodsFor: 'callbacks' stamp: 'lr 4/25/2007 18:43'! text | contents | contents := self methodNode sourceText asText. self methodNode isDoIt ifFalse: [ contents := contents makeSelectorBold ]. ^ contents! ! !ODContextDefinition methodsFor: 'callbacks' stamp: 'lr 4/26/2007 10:11'! text: aString | home class | home := context finalBlockHome. class := home receiver class whichClassIncludesSelector: home selector. (class compile: aString) ifNil: [ ^ false ]. node process popTo: home; restartTopWith: (class compiledMethodAt: home selector); stepToSendOrReturn. OBAnnouncer current announce: (OBChildrenChanged node: node parent); announce: (OBSelectingNode node: node parent currentContextNode). ^ true! ! OBBrowser subclass: #ODDebugger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODDebugger class methodsFor: 'configuration' stamp: 'lr 4/25/2007 19:59'! defaultMetaNode | process context | process := OBMetaNode named: 'process'. context := OBMetaNode named: 'context'. process childAt: #shortStack put: context. ^ process! ! !ODDebugger class methodsFor: 'opening' stamp: 'lr 4/26/2007 09:07'! openProcess: aProcess ^ (self process: aProcess) open! ! !ODDebugger class methodsFor: 'opening' stamp: 'lr 4/26/2007 09:07'! openProcess: aProcess context: aContext ^ (self process: aProcess context: aContext) open! ! !ODDebugger class methodsFor: 'configuration' stamp: 'lr 4/25/2007 14:16'! paneCount ^ 1! ! !ODDebugger class methodsFor: 'instance-creation' stamp: 'lr 4/26/2007 09:09'! process: aProcess ^ self process: aProcess context: nil! ! !ODDebugger class methodsFor: 'instance-creation' stamp: 'lr 4/26/2007 09:05'! process: aProcess context: aContext | processNode contextNode | aProcess isSuspended ifFalse: [ self error: 'Unable to debug a running process.' ]. processNode := ODProcessNode process: aProcess. contextNode := ODContextNode parent: processNode context: (aContext ifNil: [ aProcess suspendedContext ]). ^ self root: processNode selection: contextNode! ! !ODDebugger class methodsFor: 'configuration' stamp: 'lr 4/25/2007 14:16'! title ^ 'Debugger'! ! !ODDebugger methodsFor: 'commands' stamp: 'lr 4/25/2007 18:10'! cmdCommands ^ ODCommand allSubclasses! ! !ODDebugger methodsFor: 'building' stamp: 'lr 4/25/2007 14:14'! defaultBackgroundColor ^ Color lightRed! ! !ODDebugger methodsFor: 'building' stamp: 'lr 4/25/2007 18:44'! initialExtent ^ 600 @ 500 ! ! OBCommand subclass: #ODCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! ODCommand subclass: #ODBrowseCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODBrowseCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:29'! execute | selector class | selector := target context selector. class := target context receiver class. class := class whichClassIncludesSelector: selector. OBSystemBrowser openOnClass: class selector: selector! ! !ODBrowseCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:29'! label ^ 'browse'! ! !ODBrowseCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:27'! wantsButton ^ true! ! !ODCommand methodsFor: 'actions' stamp: 'lr 4/26/2007 09:17'! announce: anAnnouncement requestor announce: anAnnouncement! ! !ODCommand methodsFor: 'accessing' stamp: 'lr 4/25/2007 20:41'! context ^ target context! ! !ODCommand methodsFor: 'testing' stamp: 'lr 4/25/2007 19:02'! isActive ^ requestor isSelected: target! ! !ODCommand methodsFor: 'accessing' stamp: 'lr 4/25/2007 20:41'! process ^ target process! ! !ODCommand methodsFor: 'actions' stamp: 'lr 4/26/2007 09:21'! update self announce: (OBChildrenChanged node: target parent). self announce: (OBSelectingNode node: target parent currentContextNode)! ! ODCommand subclass: #ODIntoCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODIntoCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:34'! execute target process step: target context; stepToSendOrReturn. self update! ! !ODIntoCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:07'! label ^ 'into'! ! !ODIntoCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:10'! wantsButton ^ true! ! ODCommand subclass: #ODOverCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODOverCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:26'! execute (target process completeStep: target context) == target context ifTrue: [ target process stepToSendOrReturn ]. self update! ! !ODOverCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:07'! label ^ 'over'! ! !ODOverCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:10'! wantsButton ^ true! ! ODCommand subclass: #ODProceedCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODProceedCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:14'! execute World allMorphs do: [ :each | each model == requestor browser ifTrue: [ each delete ] ]. target process resume! ! !ODProceedCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:20'! icon ^ MenuIcons tryIcons: #(smallForwardIcon)! ! !ODProceedCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:07'! label ^ 'proceed'! ! !ODProceedCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:10'! wantsButton ^ true! ! ODCommand subclass: #ODRestartCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODRestartCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:35'! execute self process popTo: self context; restartTop; stepToSendOrReturn. self update! ! !ODRestartCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:20'! icon ^ MenuIcons tryIcons: #(smallBackIcon)! ! !ODRestartCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:09'! label ^ 'restart'! ! !ODRestartCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:10'! wantsButton ^ true! ! ODCommand subclass: #ODReturnCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODReturnCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:39'! execute | expression value | expression := OBTextRequest prompt: 'Enter expression for return value:' template: 'nil'. value := Compiler new evaluate: expression in: target context to: target context receiver. target process popTo: target context sender value: value; stepToSendOrReturn. self update! ! !ODReturnCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:15'! label ^ 'return'! ! !ODReturnCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:15'! wantsButton ^ true! ! ODCommand subclass: #ODTroughCommand instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODTroughCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/26/2007 09:34'! execute target process stepToHome: target context; stepToSendOrReturn. self update! ! !ODTroughCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:09'! label ^ 'trough'! ! !ODTroughCommand methodsFor: 'as yet unclassified' stamp: 'lr 4/25/2007 18:10'! wantsButton ^ true! ! OBNode subclass: #ODDebugNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! ODDebugNode subclass: #ODContextNode instanceVariableNames: 'parent context' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODContextNode class methodsFor: 'instance-creation' stamp: 'lr 4/26/2007 09:05'! parent: aProcessNode context: aContext ^ self basicNew initializeParent: aProcessNode context: aContext! ! !ODContextNode methodsFor: 'comparing' stamp: 'lr 4/26/2007 09:11'! = anObject ^ self class == anObject class and: [ self context == anObject context ]! ! !ODContextNode methodsFor: 'accessing' stamp: 'lr 4/25/2007 19:48'! context ^ context! ! !ODContextNode methodsFor: 'comparing' stamp: 'lr 4/25/2007 19:56'! hash ^ self context hash! ! !ODContextNode methodsFor: 'initialization' stamp: 'lr 4/26/2007 09:11'! initializeParent: aProcessNode context: aContext parent := aProcessNode. context := aContext ! ! !ODContextNode methodsFor: 'accessing' stamp: 'lr 4/26/2007 09:22'! name ^ self context asString! ! !ODContextNode methodsFor: 'accessing' stamp: 'lr 4/26/2007 09:17'! parent ^ parent! ! !ODContextNode methodsFor: 'accessing' stamp: 'lr 4/25/2007 19:48'! process ^ parent process! ! !ODDebugNode methodsFor: 'accessing' stamp: 'lr 4/25/2007 19:13'! context "Answer a suspended context." self subclassResponsibility! ! !ODDebugNode methodsFor: 'public' stamp: 'lr 4/26/2007 10:00'! definition ^ ODContextDefinition node: self! ! !ODDebugNode methodsFor: 'accessing' stamp: 'lr 4/25/2007 19:12'! process "Answer the suspended process." self subclassResponsibility! ! ODDebugNode subclass: #ODProcessNode instanceVariableNames: 'process' classVariableNames: '' poolDictionaries: '' category: 'OB-Debugger'! !ODProcessNode class methodsFor: 'instance-creation' stamp: 'lr 4/26/2007 09:06'! process: aProcess ^ self basicNew initializeProcess: aProcess! ! !ODProcessNode methodsFor: 'comparing' stamp: 'lr 4/26/2007 09:11'! = anObject ^ self class == anObject class and: [ self process == anObject process ]! ! !ODProcessNode methodsFor: 'accessing' stamp: 'lr 4/26/2007 09:11'! context ^ process suspendedContext! ! !ODProcessNode methodsFor: 'navigation' stamp: 'lr 4/26/2007 09:21'! currentContextNode ^ ODContextNode parent: self context: self context! ! !ODProcessNode methodsFor: 'comparing' stamp: 'lr 4/25/2007 19:48'! hash ^ self process hash! ! !ODProcessNode methodsFor: 'initialization' stamp: 'lr 4/26/2007 09:11'! initializeProcess: aProcess process := aProcess! ! !ODProcessNode methodsFor: 'navigation' stamp: 'lr 4/25/2007 20:24'! longStack ^ self stackOfSize: 1024! ! !ODProcessNode methodsFor: 'accessing' stamp: 'lr 4/26/2007 09:22'! name ^ self process asString! ! !ODProcessNode methodsFor: 'accessing' stamp: 'lr 4/26/2007 09:11'! process ^ process! ! !ODProcessNode methodsFor: 'navigation' stamp: 'lr 4/25/2007 20:25'! shortStack ^ self stackOfSize: 64! ! !ODProcessNode methodsFor: 'navigation' stamp: 'lr 4/26/2007 09:05'! stackOfSize: anInteger "Answer a stack of contexts of the given size." | current stack | current := self context. stack := OrderedCollection new: anInteger. [ current notNil and: [ stack size < anInteger ] ] whileTrue: [ stack addLast: (ODContextNode parent: self context: current). current := current sender ]. ^ stack! !