'From Cuis 1.0 of 28 November 2009 [latest update: #337] on 10 December 2009 at 8:28:48 am'!
!classDefinition: #Debugger category: #'Tools-Debugger'!
CodeHolder subclass: #Debugger
	instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC debuggerMap savedCursor isolationHead failedProject errorWasInUIProcess labelString message '
	classVariableNames: 'ContextStackKeystrokes ErrorRecursion '
	poolDictionaries: ''
	category: 'Tools-Debugger'!

!Debugger methodsFor: 'initialize' stamp: 'ab 3/23/2005 14:03'!
customButtonSpecs
	"Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger."

	| list |
	list := #(('Proceed'	proceed				'close the debugger and proceed.')
		('Restart'		restart				'reset this context to its start.')
		('Into'			send				'step Into message sends')
		('Over'			doStep				'step Over message sends')
		('Through'		stepIntoBlock		'step into a block')
		('Full Stack'		fullStack			'show full stack')
		('Where'		where				'select current pc range')
		('Tally'			tally				'time in milliseconds to execute')).
	Preferences restartAlsoProceeds ifTrue:
		[list := list collect: [:each |
			each second == #restart
				ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself]
				ifFalse: [each]]].
	^ list! !

!Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:07'!
notifierButtonHeight

	^ 18! !

!Debugger methodsFor: 'initialize' stamp: 'jmv 12/10/2009 07:59'!
openFullNoSuspendLabel: aString
	"Create and schedule a full debugger with the given label. Do not terminate the current active process."

	self openFullMorphicLabel: aString.
	errorWasInUIProcess _ ProjectX newProcessIfUIX: interruptedProcess! !

!Debugger methodsFor: 'initialize' stamp: 'ar 8/7/2009 23:08'!
optionalButtonPairs
	"Actually, return triples.  Only the custom debugger-specific buttons are shown"
	^ self customButtonSpecs! !

!Debugger methodsFor: 'initialize' stamp: 'jmv 12/10/2009 07:58'!
preDebugButtonQuads

	^{
	{'Proceed'.		#proceed. 	#blue. 	'continue execution'}.
	{'Abandon'.		#abandon. 	#black.	'abandon this execution by closing this window'}.
	{'Debug'.		#debug.		#red. 		'bring up a debugger'}}! !

!Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'!
release

	self windowIsClosing.
	super release.
! !

!Debugger methodsFor: 'accessing' stamp: 'di 10/9/1998 17:15'!
contents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents == nil ifTrue: [^ String new].
	^ contents copy! !

!Debugger methodsFor: 'accessing' stamp: 'eem 2/25/2009 11:46'!
contents: aText notifying: aController
	"The retrieved information has changed and its source must now be updated.
	 In this case, the retrieved information is the method of the selected context."
	| result selector classOfMethod category h ctxt newMethod |
	contextStackIndex = 0 ifTrue:
		[^false].
	self selectedContext isExecutingBlock ifTrue:
		[h := self selectedContext activeHome.
		 h ifNil:
			[self inform: 'Method for block not found on stack, can''t edit and continue'.
			 ^false].
		 (self confirm: 'I will have to revert to the method from\which this block originated.  Is that OK?' withCRs) ifFalse:
			[^false].
		self resetContext: h.
		result := self contents: aText notifying: aController.
		self contentsChanged.
		^result].

	classOfMethod := self selectedClass.
	category := self selectedMessageCategoryName.
	selector := self selectedClass parserClass new parseSelector: aText.
	(selector == self selectedMessageName
	 or: [(self selectedMessageName beginsWith: 'DoIt')
		and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse:
		[self inform: 'can''t change selector'.
		 ^false].
	selector := classOfMethod
				compile: aText
				classified: category
				notifying: aController.
	selector ifNil: [^false]. "compile cancelled"
	contents := aText.
	newMethod := classOfMethod compiledMethodAt: selector.
	newMethod isQuick ifTrue:
		[self down.
		 self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)].
	ctxt := interruptedProcess popTo: self selectedContext.
	ctxt == self selectedContext
		ifFalse:
			[self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs]
		ifTrue:
			[newMethod isQuick ifFalse:
				[interruptedProcess
					restartTopWith: newMethod;
				 	stepToSendOrReturn].
			contextVariablesInspector object: nil].
	self resetContext: ctxt.
	Smalltalk isMorphic ifTrue:
		[World
			addAlarm: #changed:
			withArguments: #(contentsSelection)
			for: self
			at: (Time millisecondClockValue + 200)].
	^true! !

!Debugger methodsFor: 'accessing' stamp: 'ar 8/17/2009 23:17'!
debuggerMap
	^debuggerMap ifNil:
		[debuggerMap := self selectedContext debuggerMap].! !

!Debugger methodsFor: 'accessing' stamp: 'md 2/20/2006 18:52'!
receiverInspectorObject: obj context: ctxt

	"set context before object so it can refer to context when building field list"
	receiverInspector context: ctxt.
	receiverInspector object: obj.
! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'eem 3/12/2009 14:54'!
selectedMessage
	"Answer the source code of the currently selected context."
	^contents := self selectedContext debuggerMap sourceText asText makeSelectorBold! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'tfel 9/15/2009 23:07'!
selectedMessageName
	"Answer the message selector of the currently selected context.
	 If the method is unbound we can still usefully answer its old selector."

	| selector |
	selector := self selectedContext selector.
	^(selector ~~ self selectedContext method selector
	    and: [selector beginsWith: 'DoIt'])
		ifTrue: [self selectedContext method selector]
		ifFalse: [selector]! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:04'!
abandon
	"abandon the debugger from its pre-debug notifier"
	self abandon: self topView! !

!Debugger methodsFor: 'context stack menu' stamp: 'jmv 12/10/2009 08:09'!
abandon: aTopView 
	"abandon the notifier represented by aTopView"
	 aTopView delete! !

!Debugger methodsFor: 'context stack menu' stamp: 'jmv 12/10/2009 08:07'!
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 addList: {
			{'fullStack (f)'.		#fullStack}.
			{'restart (r)'.		#restart}.
			{'proceed (p)'.		#proceed}.
			{'step (t)'.			#doStep}.
			{'step through (T)'.	#stepIntoBlock}.
			{'send (e)'.			#send}.
			{'where (w)'.		#where}.
			{'peel to first like this'.		#peelToFirst}.
			#-.
			{'return entered value'.		#returnValue}.
			#-.
			{'toggle break on entry'.	#toggleBreakOnEntry}.
			{'senders of... (n)'.			#browseSendersOfMessages}.
			{'implementors of... (m)'.	#browseMessages}.
			{'inheritance (i)'.	#methodHierarchy}.
			#-.
			{'versions (v)'.		#browseVersions}.
			{'inst var refs...'.		#browseInstVarRefs}.
			#-.
			{'inst var defs...'.	#browseInstVarDefs}.
			{'class var refs...'.	#browseClassVarRefs}.
			{'class variables'.	#browseClassVariables}.
			#-.
			{'class refs (N)'.		#browseClassRefs}.
			{'browse full (b)'.	#browseMethodFull}.
			{'file out '.			#fileOutMessage}.
			#-.
			{'more...'.		#shiftedYellowButtonActivity}.
		}.
	] ifTrue: [
		aMenu addList: {
			{'browse class hierarchy'.	#classHierarchy}.
			{'browse class'.				#browseClass}.
			{'browse method (O)'.		#openSingleMessageBrowser}.
			{'implementors of sent messages'.		#browseAllMessages}.
			{'change sets with this method'.		#findMethodInChangeSets}.
			#-.
			{'inspect instances'.		#inspectInstances}.
			{'inspect subinstances'.		#inspectSubInstances}.
			#-.
			{'revert to previous version'.			#revertToPreviousVersion}.
			{'remove from current change set'.		#removeFromCurrentChanges}.
			{'revert & remove from changes'.		#revertAndForget}.
			#-.
			{'more...'.					#unshiftedYellowButtonActivity}. 
		}
	].! !

!Debugger methodsFor: 'context stack menu' stamp: 'md 2/20/2006 20:23'!
peelToFirst
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| ctxt |
	contextStackIndex = 0 ifTrue: [^ Beeper beep].
	"self okToChange ifFalse: [^ self]."
	ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender.
	self resetContext: ctxt.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'jmv 12/10/2009 08:07'!
returnValue
	"Force a return of a given value to the previous context!!"

	| previous selectedContext expression value |
	contextStackIndex = 0 ifTrue: [^Beeper beep].
	selectedContext := self selectedContext.
	expression := FillInTheBlank default request: 'Enter expression for return value:'.
	value := Compiler new 
				evaluate: expression
				in: selectedContext
				to: selectedContext receiver.
	previous := selectedContext sender.
	self resetContext: previous.
	interruptedProcess popTo: previous value: value! !

!Debugger methodsFor: 'code pane' stamp: 'ar 8/17/2009 23:18'!
aboutToStyle: aStyler
	"This is a notification that aStyler is about to re-style its text.
	Set the classOrMetaClass in aStyler, so that identifiers
	will be resolved correctly.
	Answer true to allow styling to proceed, or false to veto the styling"
	
	self isModeStyleable ifFalse: [^false].
	aStyler 
		classOrMetaClass: self selectedClassOrMetaClass;
		sourceMap: self debuggerMap.
	^true! !

!Debugger methodsFor: 'code pane' stamp: 'eem 3/12/2009 14:54'!
pcRange
	"Answer the indices in the source code for the method corresponding to 
	the selected context's program counter value."

	(selectingPC and: [contextStackIndex ~= 0]) ifFalse:
		[^1 to: 0].
	self selectedContext isDead ifTrue:
		[^1 to: 0].
	^self selectedContext debuggerMap
		rangeForPC: self selectedContext pc
		contextIsActiveContext: contextStackIndex = 1! !

!Debugger methodsFor: 'code pane menu' stamp: 'nk 8/6/2003 13:52'!
codePaneMenu: aMenu shifted: shifted
	aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval.
	aMenu addLine.
	super codePaneMenu: aMenu shifted: shifted.
	^aMenu.! !

!Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:32'!
selectedClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext methodClass! !

!Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:29'!
selectedClassOrMetaClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedClass! !

!Debugger methodsFor: 'private' stamp: 'eem 3/12/2009 14:55'!
contextStackIndex: anInteger oldContextWas: oldContext 
	"Change the context stack index to anInteger, perhaps in response to user selection."

	| isNewMethod selectedContextSlotName index |
	contextStackIndex := anInteger.
	anInteger = 0 ifTrue:
		[currentCompiledMethod := contents := nil.
		 self changed: #contextStackIndex.
		 self decorateButtons.
		 self contentsChanged.
		 contextVariablesInspector object: nil.
		 receiverInspector object: self receiver.
		 ^self].
	selectedContextSlotName := contextVariablesInspector selectedSlotName.
	isNewMethod := oldContext == nil
					or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)].
	isNewMethod ifTrue:
		[contents := self selectedMessage.
		 self contentsChanged.
		 self pcRange].
	self changed: #contextStackIndex.
	self decorateButtons.
	contextVariablesInspector object: self selectedContext.
	((index := contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0
	 and: [index ~= contextVariablesInspector selectionIndex]) ifTrue:
		[contextVariablesInspector toggleIndex: index].
	receiverInspector object: self receiver.
	isNewMethod ifFalse:
		[self changed: #contentsSelection]! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
createMethod
	"Should only be called when this Debugger was created in response to a
	MessageNotUnderstood exception. Create a stub for the method that was
	missing and proceed into it."
	
	| msg chosenClass |
	msg := contextStackTop tempAt: 1.
	chosenClass := self
		askForSuperclassOf: contextStackTop receiver class
		toImplement: msg selector
		ifCancel: [^self].
	self implement: msg inClass: chosenClass.
! !

!Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'!
resetContext: aContext 
	"Used when a new context becomes top-of-stack, for instance when the
	method of the selected context is re-compiled, or the simulator steps or
	returns to a new method. There is room for much optimization here, first
	to save recomputing the whole stack list (and text), and secondly to avoid
	recomposing all that text (by editing the paragraph instead of recreating it)."

	| oldContext |
	oldContext := self selectedContext.
	contextStackTop := aContext.
	self newStack: contextStackTop contextStack.
	self changed: #contextStackList.
	self contextStackIndex: 1 oldContextWas: oldContext.
	self contentsChanged.
! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 8/8/2009 17:06'!
buildFullWith: builder
	| windowSpec listSpec textSpec extent |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec label: 'Debugger'.
	Display height < 800 "a small screen" 
		ifTrue:[extent := RealEstateAgent standardWindowExtent]
		ifFalse:[extent := 600@700].
	windowSpec extent: extent.
	windowSpec children: OrderedCollection new.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self;
		list: #contextStackList; 
		getIndex: #contextStackIndex; 
		setIndex: #toggleContextStackIndex:; 
		menu: #contextStackMenu:shifted:; 
		keyPress: #contextStackKey:from:;
		frame: (0@0 corner: 1@0.22).
	windowSpec children add: listSpec.


	textSpec := self buildCodePaneWith: builder.
	textSpec frame: (0@0.22corner: 1@0.8).
	windowSpec children add: textSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self receiverInspector;
		list: #fieldList; 
		getIndex: #selectionIndex; 
		setIndex: #toggleIndex:; 
		menu: #fieldListMenu:; 
		keyPress: #inspectorKey:from:;
		frame: (0@0.8 corner: 0.2@1).
	windowSpec children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self receiverInspector;
		getText: #contents; 
		setText: #accept:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0.2@0.8 corner: 0.5@1).
	windowSpec children add: textSpec.

	listSpec := builder pluggableListSpec new.
	listSpec 
		model: self contextVariablesInspector;
		list: #fieldList; 
		getIndex: #selectionIndex; 
		setIndex: #toggleIndex:; 
		menu: #fieldListMenu:; 
		keyPress: #inspectorKey:from:;
		frame: (0.5@0.8 corner: 0.7@1).
	windowSpec children add: listSpec.

	textSpec := builder pluggableTextSpec new.
	textSpec 
		model: self contextVariablesInspector;
		getText: #contents; 
		setText: #accept:; 
		selection: #contentsSelection; 
		menu: #codePaneMenu:shifted:;
		frame: (0.7@0.8 corner: 1@1).
	windowSpec children add: textSpec.

	^builder build: windowSpec! !

!Debugger methodsFor: 'toolbuilder' stamp: 'jmv 12/10/2009 08:16'!
buildNotifierWith: builder label: label message: messageString
	| windowSpec listSpec textSpec panelSpec buttonSpec quads |
	windowSpec := builder pluggableWindowSpec new.
	windowSpec model: self.
	windowSpec extent: 450 @ 156. "nice and wide to show plenty of the error msg"
	windowSpec label: label.
	windowSpec children: OrderedCollection new.

	panelSpec := builder pluggablePanelSpec new.
	panelSpec children: OrderedCollection new.
	quads := self preDebugButtonQuads.
	(self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
		quads := quads copyWith: 
			{ 'Create'. #createMethod. #magenta. 'create the missing method' }
	].
	quads do:[:spec|
		buttonSpec := builder pluggableButtonSpec new.
		buttonSpec model: self.
		buttonSpec label: spec first.
		buttonSpec action: spec second.
		buttonSpec help: spec fourth.
		panelSpec children add: buttonSpec.
	].
	panelSpec layout: #horizontal. "buttons"
	panelSpec frame: (0@0 corner: 1@0.2).
	windowSpec children add: panelSpec.

	messageString notNil ifFalse:[
		listSpec := builder pluggableListSpec new.
		listSpec 
			model: self;
			list: #contextStackList; 
			getIndex: #contextStackIndex; 
			setIndex: #debugAt:; 
			frame: (0@0.2 corner: 1@1).
		windowSpec children add: listSpec.
	] ifTrue:[
		message := messageString.
		textSpec := builder pluggableTextSpec new.
		textSpec 
			model: self;
			getText: #preDebugMessageString; 
			setText: nil; 
			selection: nil; 
			menu: #debugProceedMenu:;
			frame: (0@0.2corner: 1@1).
		windowSpec children add: textSpec.
	].

	^windowSpec! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 2/11/2005 16:24'!
buildWith: aBuilder
	^self buildFullWith: aBuilder! !

!Debugger methodsFor: 'toolbuilder' stamp: 'rkrk 8/24/2009 05:48'!
preDebugMessageString
	^ message ifNil: ['An error has occurred; you should probably just hit ''abandon''.  Sorry!!'].! !

!Debugger methodsFor: 'toolbuilder' stamp: 'ar 8/8/2009 17:18'!
wantsAnnotationPane
	"Annotations don't look good in debugger. Suppress 'em."
	^false! !

!Debugger methodsFor: 'tally support' stamp: 'ab 5/22/2007 14:17'!
getSelectedText
	| m interval text |
	m := self getTextMorphWithSelection.
	interval := m selectionInterval.
	text := m text.
	^ text copyFrom: interval first to: interval last
	! !

!Debugger methodsFor: 'tally support' stamp: 'nice 11/11/2009 19:13'!
getTextMorphWithSelection
	"This is extremely ugly... We I need to get a reference of the code pane, which is not easily accessible"
	^self dependents
		detect: [:m| (m isKindOf: PluggableTextMorph)
			and: [m selectionInterval first > 1]]
		ifNone: [nil]! !

!Debugger methodsFor: 'tally support' stamp: 'ab 5/22/2007 13:35'!
tally

	self getTextMorphWithSelection ifNotNilDo: [:o| o tallyIt] ifNil: [Beeper beep]
! !


!Debugger class methodsFor: 'opening' stamp: 'jmv 12/10/2009 08:05'!
openOn: process context: context label: title contents: contentsStringOrNil fullView: bool
	"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."

	| errorWasInUIProcess |
	errorWasInUIProcess _ ProjectX newProcessIfUIX: process.
	WorldState addDeferredUIMessage: [ 
		[	| debugger |
			debugger := self new process: process controller: nil context: context.
			"schedule debugger in deferred UI message to address redraw
			problems after opening a debugger e.g. from the testrunner."
			"WorldState addDeferredUIMessage: ["
			bool
				ifTrue: [debugger openFullNoSuspendLabel: title]
				ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
			debugger errorWasInUIProcess: errorWasInUIProcess.
			Preferences logDebuggerStackToFile ifTrue: [
				Smalltalk logError: title inContext: context to: 'SqueakDebug.log'].
		] on: Error do: [:ex |
			self primitiveError: 
				'Orginal error: ', 
				title asString, '.
	Debugger error: ', 
				([ex description] on: Error do: ['a ', ex class printString]), ':'
		]
	].
	process suspend! !


!Parser methodsFor: 'error correction' stamp: 'jmv 12/10/2009 08:14'!
correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction
	"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated.  abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector.  Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."

	| correctSelector userSelection |
	"If we can't ask the user, assume that the keyword will be defined later"
	self interactive ifFalse: [^proposedKeyword asSymbol].

	userSelection := requestor selectionInterval.
	requestor selectFrom: spots first first to: spots last last.

	correctSelector := UnknownSelector name: proposedKeyword.
	correctSelector ifNil: [^abortAction value].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	self substituteSelector: correctSelector keywords wordIntervals: spots.
	^(proposedKeyword last ~~ $:
	   and: [correctSelector last == $:])
		ifTrue: [abortAction value]
		ifFalse: [correctSelector]! !

!Parser methodsFor: 'error correction' stamp: 'jmv 12/10/2009 08:15'!
correctVariable: proposedVariable interval: spot 
	"Correct the proposedVariable to a known variable, or declare it as a new
	variable if such action is requested.  We support declaring lowercase
	variables as temps or inst-vars, and uppercase variables as Globals or 
	ClassVars, depending on whether the context is nil (class=UndefinedObject).
	Spot is the interval within the test stream of the variable.
	rr 3/4/2004 10:26 : adds the option to define a new class. "

	"Check if this is an i-var, that has been corrected already (ugly)"

	"Display the pop-up menu"

	| tempIvar binding userSelection action |
	(encoder classEncoding instVarNames includes: proposedVariable) ifTrue: 
		[^InstanceVariableNode new 
			name: proposedVariable
			index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)].

	"If we can't ask the user for correction, make it undeclared"
	self interactive ifFalse: [^encoder undeclared: proposedVariable].

	"First check to see if the requestor knows anything about the variable"
	tempIvar := proposedVariable first isLowercase.
	(tempIvar and: [(binding := requestor bindingOf: proposedVariable) notNil]) 
		ifTrue: [^encoder global: binding name: proposedVariable].
	userSelection := requestor selectionInterval.
	requestor selectFrom: spot first to: spot last.

	"Build the menu with alternatives"
	action := UndeclaredVariable 
				signalFor: self
				name: proposedVariable
				inRange: spot.
	action ifNil: [^self fail].

	"Execute the selected action"
	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	^action value! !

!Parser methodsFor: 'error correction' stamp: 'jmv 12/10/2009 08:15'!
queryUndefined
	| varStart varName | 
	varName := parseNode key.
	varStart := self endOfLastToken + requestorOffset - varName size + 1.
	requestor selectFrom: varStart to: varStart + varName size - 1.
	(UndefinedVariable name: varName) ifFalse: [^ self fail]! !


!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:38'!
buildList
	| list obj parent object key |
	list := OrderedCollection new.
	obj := goal.
	
	[list addFirst: obj.
	obj := parents at: obj ifAbsent: [].
	obj == nil] whileFalse.
	list removeFirst.
	parent := Smalltalk.
	objectList := OrderedCollection new.
	pointerList := OrderedCollection new.
	[list isEmpty]
		whileFalse: 
			[object := list removeFirst.
			key := nil.
			(parent isKindOf: Dictionary)
				ifTrue: [list size >= 2
						ifTrue: 
							[key := parent keyAtValue: list second ifAbsent: [].
							key == nil
								ifFalse: 
									[object := list removeFirst; removeFirst.
									pointerList add: key printString , ' -> ' , object class name]]].
			key == nil
				ifTrue: 
					[parent class == object ifTrue: [key := 'CLASS'].
					key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
									== object ifTrue: [key := parent class allInstVarNames at: i]]]].
					key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
									== object ifTrue: [key := i printString]]]].
					key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
					key == nil ifTrue: [(parent isCompiledMethod and: [object isVariableBinding]) ifTrue: [key := 'literals?']].
					key == nil ifTrue: [key := '???'].
					pointerList add: key , ': ' , object class name].
			objectList add: object.
			parent := object]! !

!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:29'!
follow: anObject from: parentObject
	anObject == goal
		ifTrue: 
			[parents at: anObject put: parentObject.
			^ true].
	anObject isLiteral ifTrue: [^ false].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	(anObject class isPointers or: [anObject isCompiledMethod]) ifFalse: [^ false].
	anObject class isWeak ifTrue: [^ false].
	(parents includesKey: anObject)
		ifTrue: [^ false].
	parents at: anObject put: parentObject.
	toDoNext add: anObject.
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'bf 2/12/2006 15:33'!
followObject: anObject
	(self follow: anObject class from: anObject)
		ifTrue: [^ true].
	"Remove this after switching to new CompiledMethod format --bf 2/12/2006"
	anObject isCompiledMethod ifTrue: [
		1 to: anObject numLiterals do:
			[:i |
			(self follow: (anObject literalAt: i) from: anObject)
				ifTrue: [^ true]].
		^false].
	1 to: anObject class instSize do:
		[:i |
		(self follow: (anObject instVarAt: i) from: anObject)
			ifTrue: [^ true]].
	1 to: anObject basicSize do:
		[:i |
		(self follow: (anObject basicAt: i) from: anObject)
			ifTrue: [^ true]].
	^ false! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'jmv 12/10/2009 08:22'!
open
	| window list |
	window _ (SystemWindow labelled: 'Pointer Finder')
		model: self.
	list _ PluggableListMorph new
		doubleClickSelector: #inspectObject;
		model: self
		listGetter: #pointerList
		indexGetter: #pointerListIndex
		indexSetter: #pointerListIndex:
		menuGetter: #menu:shifted:
		keystrokeAction: #arrowKey:from:.
	"For doubleClick to work best disable autoDeselect"
	list autoDeselect: false.
	window addMorph: list frame: (0@0 extent: 1@1).
	list color: Color lightMagenta.
	window openInWorld! !


!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:49'!
pointersTo: anObject
	"Find all occurrences in the system of pointers to the argument anObject."
	"(PointerFinder pointersTo: Browser) inspect."

	^ self pointersTo: anObject except: #()
! !

!PointerFinder class methodsFor: 'utilities' stamp: 'ar 8/6/2009 23:26'!
pointersTo: anObject except: objectsToExclude
	"Find all occurrences in the system of pointers to the argument anObject. 
	Remove objects in the exclusion list from the results."
	
	| results anObj lastObj |
	Smalltalk garbageCollect.
	"big collection shouldn't grow, so it's contents array is always the same"
	results := OrderedCollection new: 1000.

	"allObjectsDo: is expanded inline to keep spurious
	 method and block contexts out of the results"
	anObj := self someObject.
	lastObj := Object new.
	[lastObj == anObj] whileFalse: [
		anObj isInMemory ifTrue: [
			(anObj pointsTo: anObject) ifTrue: [
				"exclude the results collector and contexts in call chain"
				((anObj ~~ results collector) and:
				 [(anObj ~~ objectsToExclude) and:
				 [(anObj ~~ thisContext) and:
				 [(anObj ~~ thisContext sender) and:
				 [anObj ~~ thisContext sender sender]]]])
					 ifTrue: [ results add: anObj ].
			]].
		anObj := anObj nextObject.
	].
	objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]].

	^ results asArray
! !

!PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:48'!
pointersToItem: index of: anArray
	"Find all occurrences in the system of pointers to the given element of the given array. 
	This is useful for tracing up a pointer chain from an inspector on the results of a previous 	call of pointersTo:. To find out who points to the second element of the results, one would 	evaluate:

		PointerFinder pointersToItem: 2 of: self

	in the inspector."

	^ self pointersTo: (anArray at: index) except: (Array with: anArray)! !


!SyntaxError methodsFor: 'initialization' stamp: 'jmv 12/10/2009 08:24'!
setClass: aClass code: aString debugger: aDebugger doitFlag: flag

	| types printables badChar |
	class _ aClass.
	debugger _ aDebugger.
	selector _ aClass parserClass new parseSelector: aString.
	types _ Smalltalk actualScannerClass classPool at: #TypeTable.	"dictionary"
	printables _ '!!@#$%&*-_=+<>{}?/\,¥£¢¤¦»¼ÐÑÒÔÓÕÉò¾òøùÀÇÈ`~`' asSet.
	badChar := aString detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [
			(printables includes: aChar) not]] ifNone: [nil].
	contents _ badChar 
		ifNil: [aString]
		ifNotNil: ['<<<This string contains a character (ascii value ', 
			badChar asciiValue printString,
			') that is not normally used in code>>> ', aString].
	category ifNil: [category _ aClass organization categoryOfElement: selector].
	category ifNil: [category _ ClassOrganizer default].
	doitFlag _ flag! !

!SyntaxError methodsFor: 'message list' stamp: 'nice 10/27/2009 10:02'!
list
	"Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."

	^ Array with: (class name, '  ', (category ifNil: ['<none>']), '  ', (selector ifNil: ['<none>']))
! !


!SyntaxError class methodsFor: 'instance creation' stamp: 'jmv 12/10/2009 08:26'!
open: aSyntaxError
	"Answer a standard system view whose model is an instance of me."

	<primitive: 19> "Simulation guard"
	self buildMorphicViewOn: aSyntaxError.
	ProjectX newProcessIfUIX: Processor activeProcess.
	^ Processor activeProcess suspend! !

SmalltalkEditor removeSelector: #select!
Debugger class removeSelector: #windowColorSpecification!
Debugger removeSelector: #close:!
Debugger removeSelector: #mailOutBugReport!
!classDefinition: #Debugger category: #'Tools-Debugger'!
CodeHolder subclass: #Debugger
	instanceVariableNames: 'interruptedProcess contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC debuggerMap savedCursor errorWasInUIProcess labelString message'
	classVariableNames: 'ContextStackKeystrokes ErrorRecursion'
	poolDictionaries: ''
	category: 'Tools-Debugger'!
CompilerExceptionsTest removeSelector: #select!
"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
Debugger initialize.
DebuggerMethodMap initialize!

