"======================================================================
|
|   Experimental Debugger
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Paolo Bonzini.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk is free software; you can redistribute it and/or modify it
| under the terms of the GNU General Public License as published by the Free
| Software Foundation; either version 2, or (at your option) any later version.
| 
| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
| details.
| 
| You should have received a copy of the GNU General Public License along with
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"


Object subclass: #Debugger
       instanceVariableNames: 'curContext receiver method ip ipAdjust stopType'
       classVariableNames: 'Breakpoints BytecodeSelectors ReturnBlock'
       poolDictionaries: ''
       category: 'Language-Implementation'
!

Debugger comment:
'I am a rewrite for the GNU Smalltalk VM. In addition I provide a simple
breakpoint facility for GNU Smalltalk.'!


!Debugger class methodsFor: 'simulation'!

simulate: aBlockClosure
    ^self new
	initialize: (aBlockClosure asContext: nil)
	dispatchBytecodes
! !

!Debugger class methodsFor: 'lightweight classes'!

subclass: anObject
    | class |
    anObject class isClass ifFalse: [ ^anObject class ].
    class := Behavior new superclass: anObject class.
    anObject changeClassTo: class.
    ^class
!

unsubclass: anObject
    anObject class isClass
	ifFalse: [ anObject changeClassTo: anObject class superclass ].
!

breakpointOn: aSymbol for: anObject
    | method class |
    class := self subclass: anObject.
    (class includesSelector: aSymbol) ifTrue: [ ^self ].
    method := (class superclass >> aSymbol) shallowCopy.
    method breakpointAt: 1.
    class addSelector: aSymbol withMethod: method.
! !

!Debugger class methodsFor: 'breakpoints'!

recordOldByte: byte atIndex: anIndex forMethod: aMethod
    "Preserve the original byte code from a compiled method, for restoration
    after the breakpoint is removed.  The implementation does not notice if
    the compiled method is shared; so a breakpoint in a compiled method will 
    cause a break in whichever classes share this method.  This does not occur
    at all in practice, so it's probably not an issue."
    | breakpointDict |
    byte == self debugByte
	ifTrue: [ ^self ].
    breakpointDict := Breakpoints at: aMethod
				 ifAbsent: [ Dictionary new ].
    breakpointDict at: anIndex put: byte
!

origByteAt: anIndex forMethod: aMethod
    "I return the original byte code at the given index for the given method.
    If there is no breakpoint for that method at that index, I return nil."
    | breakpointDict |
    breakpointDict := Breakpoints at: aMethod
				 ifAbsent: [ ^nil ].
    ^breakpointDict at: anIndex
		    ifAbsent: [ ^nil ]
! !



!Debugger class methodsFor: 'private'!

initialize
    Breakpoints := IdentityDictionary new.

    BytecodeSelectors := #(
	pushRecVar: 1		"bytecode 0"
	pushRecVar: 2		"bytecode 1"
	pushRecVar: 3		"bytecode 2"
	pushRecVar: 4		"bytecode 3"
	pushRecVar: 5		"bytecode 4"
	pushRecVar: 6		"bytecode 5"
	pushRecVar: 7		"bytecode 6"
	pushRecVar: 8		"bytecode 7"
	pushRecVar: 9		"bytecode 8"
	pushRecVar: 10		"bytecode 9"
	pushRecVar: 11		"bytecode 10"
	pushRecVar: 12		"bytecode 11"
	pushRecVar: 13		"bytecode 12"
	pushRecVar: 14		"bytecode 13"
	pushRecVar: 15		"bytecode 14"
	pushRecVar: 16		"bytecode 15"

	pushTemp: 1		"bytecode 16"
	pushTemp: 2		"bytecode 17"
	pushTemp: 3		"bytecode 18"
	pushTemp: 4		"bytecode 19"
	pushTemp: 5		"bytecode 20"
	pushTemp: 6		"bytecode 21"
	pushTemp: 7		"bytecode 22"
	pushTemp: 8		"bytecode 23"
	pushTemp: 9		"bytecode 24"
	pushTemp: 10		"bytecode 25"
	pushTemp: 11		"bytecode 26"
	pushTemp: 12		"bytecode 27"
	pushTemp: 13		"bytecode 28"
	pushTemp: 14		"bytecode 29"
	pushTemp: 15		"bytecode 30"
	pushTemp: 16		"bytecode 31"

	pushLit: 1		"bytecode 32"
	pushLit: 2		"bytecode 33"
	pushLit: 3		"bytecode 34"
	pushLit: 4		"bytecode 35"
	pushLit: 5		"bytecode 36"
	pushLit: 6		"bytecode 37"
	pushLit: 7		"bytecode 38"
	pushLit: 8		"bytecode 39"
	pushLit: 9		"bytecode 40"
	pushLit: 10		"bytecode 41"
	pushLit: 11		"bytecode 42"
	pushLit: 12		"bytecode 43"
	pushLit: 13		"bytecode 44"
	pushLit: 14		"bytecode 45"
	pushLit: 15		"bytecode 46"
	pushLit: 16		"bytecode 47"
	pushLit: 17		"bytecode 48"
	pushLit: 18		"bytecode 49"
	pushLit: 19		"bytecode 50"
	pushLit: 20		"bytecode 51"
	pushLit: 21		"bytecode 52"
	pushLit: 22		"bytecode 53"
	pushLit: 23		"bytecode 54"
	pushLit: 24		"bytecode 55"
	pushLit: 25		"bytecode 56"
	pushLit: 26		"bytecode 57"
	pushLit: 27		"bytecode 58"
	pushLit: 28		"bytecode 59"
	pushLit: 29		"bytecode 60"
	pushLit: 30		"bytecode 61"
	pushLit: 31		"bytecode 62"
	pushLit: 32		"bytecode 63"

	pushVar: 1		"bytecode 64"
	pushVar: 2		"bytecode 65"
	pushVar: 3		"bytecode 66"
	pushVar: 4		"bytecode 67"
	pushVar: 5		"bytecode 68"
	pushVar: 6		"bytecode 69"
	pushVar: 7		"bytecode 70"
	pushVar: 8		"bytecode 71"
	pushVar: 9		"bytecode 72"
	pushVar: 10		"bytecode 73"
	pushVar: 11		"bytecode 74"
	pushVar: 12		"bytecode 75"
	pushVar: 13		"bytecode 76"
	pushVar: 14		"bytecode 77"
	pushVar: 15		"bytecode 78"
	pushVar: 16		"bytecode 79"
	pushVar: 17		"bytecode 80"
	pushVar: 18		"bytecode 81"
	pushVar: 19		"bytecode 82"
	pushVar: 20		"bytecode 83"
	pushVar: 21		"bytecode 84"
	pushVar: 22		"bytecode 85"
	pushVar: 23		"bytecode 86"
	pushVar: 24		"bytecode 87"
	pushVar: 25		"bytecode 88"
	pushVar: 26		"bytecode 89"
	pushVar: 27		"bytecode 90"
	pushVar: 28		"bytecode 91"
	pushVar: 29		"bytecode 92"
	pushVar: 30		"bytecode 93"
	pushVar: 31		"bytecode 94"
	pushVar: 32		"bytecode 95"

	stRecVar: 1		"bytecode 96"
	stRecVar: 2		"bytecode 97"
	stRecVar: 3		"bytecode 98"
	stRecVar: 4		"bytecode 99"
	stRecVar: 5		"bytecode 100"
	stRecVar: 6		"bytecode 101"
	stRecVar: 7		"bytecode 102"
	stRecVar: 8		"bytecode 103"

	stTemp: 1		"bytecode 104"
	stTemp: 2		"bytecode 105"
	stTemp: 3		"bytecode 106"
	stTemp: 4		"bytecode 107"
	stTemp: 5		"bytecode 108"
	stTemp: 6		"bytecode 109"
	stTemp: 7		"bytecode 110"
	stTemp: 8		"bytecode 111"

	pushSelf: nil		"bytecode 112"
	pushTrue: nil		"bytecode 113"
	pushFalse: nil		"bytecode 114"
	pushNil: nil		"bytecode 115"
	push: -1		"bytecode 116"
	push: 0			"bytecode 117"
	push: 1			"bytecode 118"
	push: 2			"bytecode 119"

	explicitRet: pushSelf:	"bytecode 120"
	explicitRet: pushTrue:	"bytecode 121"
	explicitRet: pushFalse:	"bytecode 122"
	explicitRet: pushNil:	"bytecode 123"

	explicitRet: 0		"bytecode 124"
	retStackTop: nil	"bytecode 125"

	bigLiterals: nil	"bytecode 126"
	breakpoint: nil	   	"bytecode 127"

	pushIndexedVal: 0	"bytecode 128"
	popAndStoreStackTop: 0	"bytecode 129"
	popAndStoreStackTop: 1	"bytecode 130"

	sendShort: nil		"bytecode 131"
	sendLong: nil		"bytecode 132"
	supSendShort: nil	"bytecode 133"
	supSendLong: nil	"bytecode 134"

	popStack: 1		"bytecode 135"
	dupStack: nil		"bytecode 136"
	
	pushThisContext: nil	"bytecode 137"

	outerVars: nil		"bytecode 138"
	shJmp: 0		"bytecode 139 - nop"

	replaceSelf: nil	"bytecode 140"
	replace: 1		"bytecode 141"
	pushIndexedVal: 1	"bytecode 142"
	unused: 143		"bytecode 143"

	shJmp: 1		"bytecode 144"
	shJmp: 2		"bytecode 145"
	shJmp: 3		"bytecode 146"
	shJmp: 4		"bytecode 147"
	shJmp: 5		"bytecode 148"
	shJmp: 6		"bytecode 149"
	shJmp: 7		"bytecode 150"
	shJmp: 8		"bytecode 151"

	shJmpFalse: 1		"bytecode 152"
	shJmpFalse: 2		"bytecode 153"
	shJmpFalse: 3 		"bytecode 154"
	shJmpFalse: 4		"bytecode 155"
	shJmpFalse: 5		"bytecode 156"
	shJmpFalse: 6		"bytecode 157"
	shJmpFalse: 7		"bytecode 158"
	shJmpFalse: 8		"bytecode 159"

	longJmp: -1024		"bytecode 160"
	longJmp: -768		"bytecode 161"
	longJmp: -512		"bytecode 162"
	longJmp: -256		"bytecode 163"
	longJmp: 0		"bytecode 164"
	longJmp: 256		"bytecode 165"
	longJmp: 512		"bytecode 166"
	longJmp: 768		"bytecode 167"

	popJmpTrue: 0		"bytecode 168"
	popJmpTrue: 256		"bytecode 169"
	popJmpTrue: 512		"bytecode 170"
	popJmpTrue: 768		"bytecode 171"

	popJmpFalse: 0		"bytecode 172"
	popJmpFalse: 256	"bytecode 173"
	popJmpFalse: 512	"bytecode 174"
	popJmpFalse: 768	"bytecode 175"

	send1: +		"bytecode 176"
	send1: -		"bytecode 177"
	send1: <		"bytecode 178"
	send1: >		"bytecode 179"
	send1: <=		"bytecode 180"
	send1: >=		"bytecode 181"
	send1: =		"bytecode 182"
	send1: ~=		"bytecode 183"
	send1: *		"bytecode 184"
	send1: /		"bytecode 185"
	send1: \\		"bytecode 186"
	send1: @		"bytecode 187"
	send1: bitShift:	"bytecode 188"
	send1: //		"bytecode 189"
	send1: bitAnd:		"bytecode 190"
	send1: bitOr:		"bytecode 191"

	send1: at:			"bytecode 192"
	send2: at:put:			"bytecode 193"
	send0: size			"bytecode 194"
	send0: next			"bytecode 195"
	send1: nextPut:			"bytecode 196"
	send0: atEnd			"bytecode 197"
	send1: ==			"bytecode 198"
	send0: class			"bytecode 199"
	doBlockCopy			"bytecode 200"
	send0: value			"bytecode 201"
	send1: value:			"bytecode 202"
	send0: do:			"bytecode 203"
	send0: new			"bytecode 204"
	send1: new:			"bytecode 205"
	send0: isNil			"bytecode 206"
	send0: notNil	   		"bytecode 207"

	sendLit0: 1		"bytecode 208"
	sendLit0: 2		"bytecode 209"
	sendLit0: 3		"bytecode 210"
	sendLit0: 4		"bytecode 211"
	sendLit0: 5		"bytecode 212"
	sendLit0: 6		"bytecode 213"
	sendLit0: 7		"bytecode 214"
	sendLit0: 8		"bytecode 215"
	sendLit0: 9		"bytecode 216"
	sendLit0: 10		"bytecode 217"
	sendLit0: 11		"bytecode 218"
	sendLit0: 12		"bytecode 219"
	sendLit0: 13		"bytecode 220"
	sendLit0: 14		"bytecode 221"
	sendLit0: 15		"bytecode 222"
	sendLit0: 16		"bytecode 223"

	sendLit1: 1		"bytecode 224"
	sendLit1: 2		"bytecode 225"
	sendLit1: 3		"bytecode 226"
	sendLit1: 4		"bytecode 227"
	sendLit1: 5		"bytecode 228"
	sendLit1: 6		"bytecode 229"
	sendLit1: 7		"bytecode 230"
	sendLit1: 8		"bytecode 231"
	sendLit1: 9		"bytecode 232"
	sendLit1: 10		"bytecode 233"
	sendLit1: 11		"bytecode 234"
	sendLit1: 12		"bytecode 235"
	sendLit1: 13		"bytecode 236"
	sendLit1: 14		"bytecode 237"
	sendLit1: 15		"bytecode 238"
	sendLit1: 16		"bytecode 239"

	sendLit2: 1		"bytecode 240"
	sendLit2: 2		"bytecode 241"
	sendLit2: 3		"bytecode 242"
	sendLit2: 4		"bytecode 243"
	sendLit2: 5		"bytecode 244"
	sendLit2: 6		"bytecode 245"
	sendLit2: 7		"bytecode 246"
	sendLit2: 8		"bytecode 247"
	sendLit2: 9		"bytecode 248"
	sendLit2: 10		"bytecode 249"
	sendLit2: 11		"bytecode 250"
	sendLit2: 12		"bytecode 251"
	sendLit2: 13		"bytecode 252"
	sendLit2: 14		"bytecode 253"
	sendLit2: 15		"bytecode 254"
	sendLit2: 16		"bytecode 255"
    )
!

returnBlock
    ^ReturnBlock
!

debugByte
    "Answer the byte code that the debugger uses for breakpoints"
    ^127
! !


!Debugger methodsFor: 'virtual machine'!

dispatchBytecodesUntil: stopTypeSymbol
    stopType := stopTypeSymbol.
    self dispatchBytecodes
!

dispatchBytecodes
    | byte type |
    receiver := curContext receiver.
    method := curContext method.
    ipAdjust := curContext method bytecodeStart.
    ip := curContext ip + ipAdjust.

    [
	byte := method at: ip.
	ip := ip + 1.
	curContext
	    perform: (BytecodeSelectors at: byte + byte + 1)
	    with:    (BytecodeSelectors at: byte + byte + 2).

	type isSymbol and: [ type == stopType ]
    ] whileFalse.

    curContext ip: ip - ipAdjust.
    ^type isSymbol ifTrue: [ nil ] ifFalse: [ type value ].

! !      

!Debugger methodsFor: 'bytecodes'!

pushRecVar: index
    ^self push: (receiver instVarAt: index).
!

pushTemp: index
    ^self push: (curContext at: index).
!

pushLit: index
    ^self push: (method literalAt: index).
!

pushVar: index
    ^self push: (method literalAt: index) value.
!

stRecVar: index
    receiver instVarAt: index put: (curContext at: curContext sp).
    curContext sp: curContext sp - 1.
    ^#store
!

stTemp: index
    curContext at: index put: (curContext at: curContext sp).
    curContext sp: curContext sp - 1.
    ^#store
!

stVar: index
    (curContext at: index)
	value: (curContext at: curContext sp).
    curContext sp: curContext sp - 1.
    ^#store
!

pushSelf: unused
    ^self push: receiver
!

pushTrue: unused
    ^self push: true
!

pushFalse: unused
    ^self push: false
!

pushNil: unused
    ^self push: nil
!

replaceSelf: unused
    curContext basicAt: curContext sp put: receiver.
    ^#push
!

replace: anObject
    curContext basicAt: curContext sp put: anObject.
    ^#push
!

push: anObject
    | sp |
    curContext
	sp: (sp := curContext sp + 1);
	basicAt: sp put: anObject.
    ^#push
!

explicitRet: selector
    | home stackTop bad |
    selector isInteger			"push self/true/false/etc."
	ifFalse: [ self perform: selector with: #nil ].

    stackTop := curContext at: curContext sp.
    curContext isBlock ifFalse: [
	curContext := curContext parentContext.
	^self doReturn: stackTop
    ].

    bad := false.
    [ (home := curContext home) parentContext isNil ] whileTrue: [
	"Walk down until we do find a valid context"
	bad := true.
	curContext := curContext parentContext
	curContext isNil ifTrue: [ ^#bad ].
    ].
    
    curContext := home.

    self doReturn: stackTop.
    bad ifFalse: [ ^#return ].	"99%"

    self send: 0 selector: #badReturnError super: false.
    ^#return
!

retStackTop: unused
    | stackTop |
    stackTop := curContext at: curContext sp.
    curContext := curContext parentContext.
    ^self doReturn: stackTop
!

doBlockCopy
    | closure outer sp |
    sp := curContext sp.
    outer := curContext at: sp.
    closure := curContext at: (sp := sp - 1).

    closure class == BlockClosure ifFalse: [ ^self send1: #blockCopy: ].
    curContext sp: sp.
    curContext at: sp put: (closure blockCopy: outer;
	receiver: receiver;
	yourself).
!

doReturn: stackTop
    curContext isNil ifTrue: [ ^#endSimulation -> stackTop ].
    self push: stackTop.
    receiver := curContext receiver.
    method := curContext method.
    ipAdjust := curContext method bytecodeStart.
    ip := curContext ip + ipAdjust.

    ^#return
!

breakpoint: unused
    receiver breakpoint: curContext return: nil.
    ip := ip - 1.
    ^#breakpoint
!

pushIndexedVal: adjust
    | byte type |
    curContext sp: curContext sp - adjust.
    byte := method at: ip. ip := ip + 1.
    type := byte bitShift: -6.
    byte := byte bitAnd: 63.
    ^self
	perform: ( #(pushRecVar: pushTemp: pushLit: pushVar:) at: type + 1)
	with: byte + 1
!

popAndStoreStackTop: adjust
    | byte type return |
    byte := method at: ip. ip := ip + 1.
    type := byte bitShift: -6.
    byte := byte bitAnd: 63.
    return := self
	perform: ( #(stRecVar: stTemp: unused: stVar:) at: type + 1)
	with: byte + 1.

    curContext sp: curContext sp - adjust.
    ^return
!

sendShort: unused
    | byte |
    byte := method at: ip. ip := ip + 1.
    ^self
	send: (byte bitShift: -5)
	selector: (method literalAt: (byte bitAnd: 31) + 1)
	super: false
!

sendLong: unused
    | byte1 byte2 |
    byte1 := method at: ip. ip := ip + 1.
    byte2 := method at: ip. ip := ip + 1.
    ^self
	send: byte1
	selector: byte2
	super: false
!

supSendShort: unused
    | byte |
    byte := method at: ip. ip := ip + 1.
    ^self
	send: (byte bitShift: -5)
	selector: (method literalAt: (byte bitAnd: 31) + 1)
	super: true
!

supSendLong: unused
    | byte1 byte2 |
    byte1 := method at: ip. ip := ip + 1.
    byte2 := method at: ip. ip := ip + 1.
    ^self
	send: byte1
	selector: byte2
	super: true
!

popStack: howMany
    curContext sp: curContext sp - howMany.
    ^#pop
!

dupStack: unused
    ^self push: (curContext at: curContext sp)
!

pushThisContext: unused
    ^self push: curContext
!

bigLiterals: unused
    | byte1 byte2 object |
    byte1 := method at: ip. ip := ip + 1.
    byte2 := method at: ip. ip := ip + 1.
    byte1 := byte1 * 256 + byte2.
    byte2 := byte1 bitShift: -14.

    object := self literalAt: byte1 + 1.
    byte2 = 0 ifTrue: [ ^self push: object ].
    byte2 = 64 ifTrue: [ ^self push: object value ].
    
    object value: (curContext at: curContext sp).
    byte2 = 128 ifTrue: [ curContext sp: curContext sp - 1 ].
    ^#store
!

outerVars: unused
    | byte1 byte2 ctx object |
    byte1 := method at: ip. ip := ip + 1.
    byte2 := method at: ip. ip := ip + 1.
    ctx := curContext outerContext: byte2.

    byte2 := byte1 bitAnd: 192.
    byte1 := (byte1 bitAnd: 63) + 1.
    byte2 = 64 ifTrue: [ ^self push: (ctx at: byte1) ].

    object := curContext at: byte1.
    byte2 = 128 ifTrue: [ curContext sp: curContext sp - 1 ].
    byte2 = 0 ifFalse: [ ctx at: byte2 + 1 put: object. ^#store ].
    ^#bad
!

unused: bytecode
    ^#bad
!

shJmp: index
    ip := ip + index.
    ^#jump
!

shJmpFalse: index
    | top |
    (top := curContext at: curContext sp) == false
	ifTrue: [ ip := ip + index ]
	ifFalse: [ top == true ifFalse: [ ^self sendMustBeBoolean ] ].

    curContext sp: curContext sp - 1.
    ^#jump
!

longJmp: adjust
    | index | 
    index := method at: ip. ip := ip + 1.
    ip := ip + index + adjust.
    ^#jump
!

popJmpFalse: adjust
    | index top | 
    index := (method at: ip) + adjust. ip := ip + 1.
    (top := curContext at: curContext sp) == false
	ifTrue: [ ip := ip + index ]
	ifFalse: [ top == true ifFalse: [ ^self sendMustBeBoolean ] ].

    curContext sp: curContext sp - 1.
    ^#jump
!

popJmpTrue: adjust
    | index top |
    index := (method at: ip) + adjust. ip := ip + 1.
    (top := curContext at: curContext sp) == true
	ifTrue: [ ip := ip + index ]
	ifFalse: [ top == false ifFalse: [ ^self sendMustBeBoolean ] ].

    curContext sp: curContext sp - 1.
    ^#jump
!

sendMustBeBoolean
    ^self send: 0 selector: #mustBeBoolean super: false
!

send0: msg
    ^self send: 0 selector: msg super: false
!

send1: msg
    ^self send: 1 selector: msg super: false
!

send2: msg
    ^self send: 2 selector: msg super: false
!

sendLit0: index
    ^self
	send: 0
	selector: (method literalAt: index)
	super: false
!

sendLit1: index
    ^self
	send: 1
	selector: (method literalAt: index)
	super: false
!

sendLit2: index
    ^self
	send: 2
	selector: (method literalAt: index)
	super: false
! !

!Debugger methodsFor: 'private'!

initialize: context
    curContext := context.
!

send: numArgs selector: selector super: superBoolean
    | args receiver sp arg class |
    sp := curContext sp - numArgs.
    args := Array new: numArgs.
    0 to: numArgs do: [ :i |
	arg := curContext at: sp + i.
	i = 0
	    ifTrue: [ receiver := arg ]
	    ifFalse: [ args at: i put: arg ].

	arg class == BlockClosure ifTrue: [
	    arg outerContext method breakpointAt: arg initialIP
	]
    ].
    curContext sp: curContext sp - numArgs.
    class := superBoolean
	ifTrue: [ curContext methodClass superclass ]
	ifFalse: [ receiver class perform: class ].

    selector = #perform:	       ifTrue: [ ^self sendPerform: args to: receiver class: class ].
    selector = #perform:with:	       ifTrue: [ ^self sendPerformWith: args to: receiver class: class ].
    selector = #perform:with:with:     ifTrue: [ ^self sendPerformWith: args to: receiver class: class ].
    selector = #perform:withArguments: ifTrue: [ ^self sendPerformWithArguments: args to: receiver class: class ].

    ^self sendMessage: selector to: receiver args: args class: class
!

sendMessage: theSelector to: receiver args: theArgs class: theClass
    | newMethod oldRetBlock return sp args selector class |
    args := theArgs.
    selector := theSelector.
    class := theClass.
    sp := curContext sp.
    [   class isNil ifTrue: [
	    "Create a #doesNotUnderstand: frame"
	    args := Array with:
		(Message selector: selector arguments: args).

	    (selector == #doesNotUnderstand:) ifTrue: [ ^#bad ].
	    selector := #doesNotUnderstand: .
	    class := receiver class
	].
	class includesSelector: selector
    ]   whileFalse: [ class := class superclass ].

    newMethod := class >> selector.
    newMethod breakpointAt: 1.

    oldRetBlock := ReturnBlock.
    ReturnBlock := [ :context :returnValue |
	"It was not a primitive, or it was a primitive but it failed.
	 We can steal the current VM status from the passed context
	 and run the simulation"

	ReturnBlock := oldRetBlock.
	curContext := context.
	receiver := curContext receiver.
	method := newMethod.
	ipAdjust := newMethod bytecodeStart.
	ip := curContext ip + ipAdjust.
	self push: returnValue.
	^#send
    ].

    return := receiver
	perform: selector
	withArguments: args.

    "It was a primitive and it succeeded. Push the return value and leave"
    ReturnBlock := oldRetBlock.
    newMethod removeBreakpointAt: 1.
    self push: return.
    ^#send
!

sendPerform: args to: receiver class: class 
    ^self
       sendMessage: (args at: 1)
       to: receiver
       args: #()
       class: class
!

sendPerformWith: args to: receiver class: class 
    ^self
       sendMessage: (args at: 1)
       to: receiver
       args: (args copyFrom: 2 to: args size)
       class: class
!

sendPerformWithArguments: args to: receiver class: class 
    ^self
       sendMessage: (args at: 1)
       to: receiver
       args: (args at: 2)
       class: class
! !

!Object methodsFor: 'debugging'!

breakpoint: context return: return
    context method removeBreakpointAt: context ip.
    Debugger returnBlock value: context value: return.
    ^return
! !

Debugger initialize!

