home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
codebug.seq
< prev
next >
Wrap
Text File
|
1990-03-07
|
26KB
|
697 lines
\\ CODEBUG.SEQ A CODE debugger for F-PC by Tom Zimmer
This file contains a simple debugger for F-PC to allow debugging
CODE routines. Don't expect TOO MUCH from this debugger, it is still
in quite primitive form. It is useful though.
The debugger can be invoked directly by:
TRACE <forth_name> <enter>
Each subsequent enter key press causes the debugger to step one
instruction through <forth_name>. Limited operations are supported while
in the debugger, read the screen while debugging and press F1 for some help.
To set a break point that will invoke the debugger when a particular
word is executed, use:
BREAKAT <forth_name> <enter>
The first time this word is executed, the code debugger will be started.
If your break point is not ever executed, you should execute UNBREAK
before leaving F-PC to remove the break point from memory.
***************************************************************************
To make a debugger for CODE, we needed to make an interrupt handler for
INT 1, and then enable the single step status flag bit TF.
{
\ **************************************************************************
\ Load the disassembler, we need it in the debugger
\ **************************************************************************
fload dis8086
( dis8086 ) symbolic off
\ **************************************************************************
\ variables to hold all needed registers
\ **************************************************************************
variable debugip
variable debugcs
variable debugflags
variable debugax
variable debugbx
variable debugcx
variable debugdx
variable debugbp variable forthbp
variable debugsi variable forthsi
variable debugdi variable forthdi
variable debuges variable forthes
variable debugss variable forthss
variable debugsp variable forthsp
variable debugds variable forthds
\ **************************************************************************
\ words to allow setting the debugging registers
\ **************************************************************************
: reg! ( a1 | <name> -- ) \ defining word to make register
\ assignment words
create , does> @ ! ;
debugcs reg! =cs
debugip reg! =ip
debugss reg! =ss
debugsp reg! =sp
debugds reg! =ds
debuges reg! =es
debugax reg! =ax
debugbx reg! =bx
debugcx reg! =cx
debugdx reg! =dx
debugsi reg! =si
debugdi reg! =di
debugbp reg! =bp
debugflags reg! =fl
: reg@ ( a1 | <name> -- ) \ defining word to make register
\ fetch words
create , does> @ @ ;
debugcs reg@ cs-@
debugip reg@ ip-@
debugss reg@ ss-@
debugsp reg@ sp-@
debugds reg@ ds-@
debuges reg@ es-@
debugax reg@ ax-@
debugbx reg@ bx-@
debugcx reg@ cx-@
debugdx reg@ dx-@
debugsi reg@ si-@
debugdi reg@ di-@
debugbp reg@ bp-@
2variable break_save
break_save off
\ **************************************************************************
\ Some handy debugging utilities
\ **************************************************************************
2 constant dbtop
rows 6 - constant dbbot
0 value dboff
0 value dbto
0 value dbsave
0 value keysave
0 value spsave
: h.4 ( n1 -- ) \ display n1 in four digit hex
$10 save!> base
0 <# # # # # #> space type space
restore> base ;
' no-name >name constant [no-name]
: sp>col ( n1 -- )
#out @ - 0max spaces ;
: dbeeol ( -- )
58 sp>col ;
: ?.cfa ( a1 -- )
>name dup [no-name] <>
if dup .id
then drop ;
: debug_depth ( -- n1 )
sp-@ sp0 @ swap - 2/ ;
: debug.s ( -- )
savecursor cursor-off
0 dbtop cols 1- dbtop 2+ box
debug_depth 0<
if ." \2 Data Stack INVALID !! "
>attrib2 cols 2- sp>col >norm
else debug_depth ?dup
if dup ." [" 1 .r ." ]" 0 swap 8 min 1-
do sp@ sp-@ swap - 2/ i + pick
7 u.r space
-1 +loop
else ." Stack Empty. "
then cols 1- sp>col
then restcursor ;
: .dbheader ( -- )
cls
0 dbtop 2- at
." \3 Enter or Space \1 = single step instruction
." \2 ESC \1 = Quit debugging \2 F1 \1 = Help "
cr
." \1 Use to select line to (G)o to. "
." \1 Press (R) to change registers. " ;
: .dbfooter ( -- )
0 dbbot 1+ at
." \1 Type \`\3STEPS\1\` to restart debugger. "
>attrib1 cols sp>col >norm cr ;
: .bytes ( a1 n1 -- )
0max bounds
?do i c@ 0 <# # # #> type space
loop ;
\ **************************************************************************
\ Display current instruction followed by data stack
\ **************************************************************************
dis8086 also
0 value ipprev
0 value ipprev2
: .inst ( -- ) \ display one instruction
save> base hex
ip-@ ?.cfa 11 sp>col
cs-@ =seg
ip-@ dup cp ! =: ipprev
>rev
ip-@ h.4 inst 44 sp>col
ip-@ cp @ over - 5 min .bytes dbeeol >norm
restore> base ;
: .ninst ( n1 -- )
save> base hex
cp @ ?.cfa 11 sp>col
1+ dboff =
if cp @ =: dbto >attrib3
then
cp @ dup>r h.4 inst 44 sp>col
r> cp @ over - 5 min .bytes dbeeol >norm
restore> base ;
: .pinst ( -- )
ipprev 0=
if dbeeol
else save> base hex
cs-@ =seg
ipprev dup cp ! =: ipprev2
cp @ ?.cfa 11 sp>col
cp @ dup>r h.4 inst 44 sp>col
r> cp @ over - 5 min .bytes dbeeol >norm
restore> base
then ;
previous
\ **************************************************************************
\ Display the processor registers
\ **************************************************************************
: .regs ( -- )
savecursor cursor-off
60 dbtop 3 + 79 dbtop 17 + box
." \3 Tom's Debugger " bcr bcr
." \1CS" cs-@ h.4 ." \1IP" ip-@ h.4 bcr
." \1DS" ds-@ h.4 ." \1SI" si-@ h.4 bcr
." \1ES" es-@ h.4 ." \1DI" di-@ h.4 bcr
." \1SS" ss-@ h.4 ." \1SP" sp-@ h.4 bcr
." \1BP" bp-@ h.4 bcr
." \1AX" ax-@ h.4 09 SPACES bcr
." \1BX" bx-@ h.4 ." \1FL" debugflags @ h.4
bcr
." \1CX" cx-@ h.4 09 SPACES bcr
." \1DX" dx-@ h.4 09 SPACES bcr
." ----ODITsz-a-p-c" bcr
2 save!> base
space
debugflags @ 0 <# 16 0 do # loop #> type
restore> base
restcursor ;
\ **************************************************************************
\ This is the single step "receiver". It saves the debugging registers
\ and restores F-PC's registers then goes back to Forth.
\ **************************************************************************
label int1 ( -- ) \ preserve all registers
push ds
push ax
mov ax, cs: forthds
mov ds, ax
pop debugax
pop debugds
pop debugip
pop debugcs
pop ax
and ax, # $FEFF \ clear TF flag bit
mov debugflags ax
mov debugbx bx
mov debugcx cx
mov debugdx dx
mov debugbp bp mov bp, forthbp
mov debugsi si mov si, forthsi
mov debugdi di mov di, forthdi
mov debuges es mov es, forthes
mov debugss ss mov ss, forthss
mov debugsp sp mov sp, forthsp
next end-code
\ **************************************************************************
\ This is the break point "receiver". It saves the debugging registers
\ and restores F-PC's registers then goes to "STEPS".
\ **************************************************************************
defer do_steps
2variable int3save
label int3 ( -- ) \ preserve all registers
push ds
push ax
mov ax, cs: forthds
mov ds, ax
pop debugax
pop debugds
pop ax
dec ax \ backup one byte to break point
mov debugip ax
pop debugcs
pop ax
and ax, # $FEFF \ clear TF flag bit
mov debugflags ax
mov debugbx bx
mov debugcx cx
mov debugdx dx
mov bx, break_save
mov ax, break_save 2+
mov 0 [bx], al \ restore break point
mov break_save # 0 word \ clear break point variable
mov debugbp bp mov bp, forthbp
mov debugsi si mov si, forthsi
mov debugdi di mov di, forthdi
mov debuges es mov es, forthes
mov debugss ss mov ss, forthss
mov debugsp sp \ mov sp, forthsp
mov cx, cs
mov ds, cx
mov dx, cs: int3save \ restore interrupt three
mov ds, cs: int3save 2+
mov ax, # $2503
int $21
mov ax, cs
mov ds, ax
mov ax, # ' do_steps \ goto "STEPS"
jmp ax
end-code
\ **************************************************************************
\ Routines to save, set & restore the number one & three interrupt vectors.
\ **************************************************************************
2variable int1save \ a place to save the interrupt one vector
code save_int# ( n1 --- ) \ save the current contents of interrupt one
pop bx
push es
mov ax, # $3500
or al, bl
int $21
mov int1save bx
mov int1save 2+ es \ save old vector
pop es
next end-code
code save_int3 ( --- ) \ save the current contents of interrupt three
push es
mov ax, # $3503
int $21
mov int3save bx
mov int3save 2+ es \ save old vector
pop es
next end-code
code set_int# ( n1 --- ) \ set interrupt one to our interrupt handler
pop bx
push es
mov ax, cs
mov ds, ax
mov dx, # int1
mov ax, # $2500
or al, bl
int $21
pop es
next end-code
code set_int3 ( --- ) \ set interrupt three to our interrupt handler
push es
mov ax, cs
mov ds, ax
mov dx, # int3
mov ax, # $2503
int $21
pop es
next end-code
code rest_int# ( n1 --- ) \ restore the contents of interrupt one
pop bx
mov cx, cs
mov ds, cx
mov dx, cs: int1save
mov ds, cs: int1save 2+
mov ax, # $2500
or al, bl
int $21
mov ax, cs
mov ds, ax
next end-code
code rest_int3 ( --- ) \ restore the contents of interrupt three
mov cx, cs
mov ds, cx
mov dx, cs: int3save
mov ds, cs: int3save 2+
mov ax, # $2503
int $21
mov ax, cs
mov ds, ax
next end-code
\ **************************************************************************
\ initiate one single instruction step. Swaps registers, sets up the
\ hardware stack with processor status, code segment, and instruction
\ pointer then does an IRET to return to do a single step. The TF flag
\ is set in the status register to make the processor immediately perform
\ an INT1 after a single instruction has been executed. Execution then
\ returns to INT1 above, and consequently back to Forth.
\ **************************************************************************
code one_step ( -- ) \ single step through one instruction as
\ already setup in the debugging recisters
mov forthsp sp
mov forthss ss
mov forthbp bp
mov forthsi si
mov forthdi di
mov forthds ds
mov forthes es
cmp debugsp # 0 \ give a default if needed.
0= if mov debugsp sp
mov debugss ss
mov debugds ds
mov debugcs cs
pushf
pop ax
and ax, # $FEFF \ clear TF flag bit
mov debugflags ax
then
mov bx, debugbx
mov cx, debugcx
mov dx, debugdx
mov bp, debugbp
mov si, debugsi
mov di, debugdi
mov ss, debugss
mov es, debuges
mov sp, debugsp
mov ax, debugflags
or ax, # $100 \ set TF bit in flags
push ax
push debugcs
push debugip
mov ax, debugax
mov ds, debugds
iret end-code
code one_break ( -- ) \ go till the breakpoint we just installed
mov forthsp sp
mov forthss ss
mov forthbp bp
mov forthsi si
mov forthdi di
mov forthds ds
mov forthes es
mov bx, debugbx
mov cx, debugcx
mov dx, debugdx
mov bp, debugbp
mov si, debugsi
mov di, debugdi
mov ss, debugss
mov es, debuges
mov sp, debugsp
mov ax, debugflags
and ax, # $FEFF \ CLEAR TF bit in flags
push ax
push debugcs
push debugip
mov ax, debugax
mov ds, debugds
iret end-code
code trace_done ( -- )
mov bx, debugbx
mov cx, debugcx
mov dx, debugdx
mov bp, debugbp
mov si, debugsi
mov di, debugdi
mov ss, debugss
mov es, debuges
mov sp, debugsp
mov ax, debugflags
and ax, # $FEFF \ CLEAR TF bit in flags
push ax
push debugcs
push debugip
mov ax, debugax
mov ds, debugds
iret end-code
\ ***************************************************************************
\ initialize the Forth registers, so they will be valid when the break point
\ occurs.
\ ***************************************************************************
: set_fregs ( -- ) \ give forth registers some defaults
sp@ forthsp !
?cs: forthss !
?cs: forthds !
rp@ forthbp !
0 forthdi !
0 forthsi !
['] quit >body @ xseg @ + forthes ! ;
\ **************************************************************************
\ Set the single step interrupt, perform a single instruction step, and
\ then restore the single step interrupt.
\ **************************************************************************
: single_step ( -- ) \ perform one instruction step, and
\ display registers with next
\ instruction to be traced.
1 save_int# \ save existing interrupt vector
1 set_int# \ set to out interrupt routine
one_step \ do a single step trace of one inst
1 rest_int# \ restore the interrupt vector
;
: break_point ( -- ) \ break point to offset specified
dbto c@ =: dbsave
dboff
if $CC dbto c! \ only break if not zero
then
3 save_int#
3 set_int#
one_break
3 rest_int#
dbsave dbto c! \ restore program byte
ip-@ 1- =ip \ backup program counter one byte
off> dboff ; \ reset break point offset
\ ***************************************************************************
\ Break point control words, allow setting, removing, and displaying
\ the current break point.
\ ***************************************************************************
: unbreak ( -- ) \ remove the break point
break_save @ ?dup
if break_save 2+ @ swap c! \ restore break point
break_save off \ clear break_save
rest_int3 \ restore vector
then defers byefunc ;
' unbreak is byefunc \ make break point removal automatic
: breakat ( | <name> -- ) \ install a break point
unbreak \ restore previous if needed
set_fregs \ give Forth registers a default
save_int3 \ save interrupt three
set_int3 \ set interrupt three
' dup break_save !
dup c@ break_save 2+ ! \ save break point
$CC swap c! \ set break point
off> ipprev
cr ." Break point set" ;
' breakat alias xx \ xx is an alias for breakat
: .break ( -- ) \ display the current break point
break_save @ ?dup cr
if ." Break point set in " >name .id
else ." No break point set"
then ;
\ **************************************************************************
\ show the current registers, and a series of instructions as they will
\ be executed.
\ **************************************************************************
: show_debug ( -- )
savecursor cursor-off
.regs
debug.s
0 dbtop 3 + 59 dbbot box
." \1 Name Addr Instruction Data "
bcr .pinst bcr .inst bcr
dbbot dbtop 4 + - 3 - 0
do i .ninst bcr
loop restcursor ;
: set_register ( -- )
ipprev2 =: ipprev
savecursor
0 dbbot 1+ 2dup at cols 1- sp>col at
sp@ >r sp-@ sp!
." \1 {in the form $23 =AX } command: "
query interpret
sp@ =sp r> sp!
0 dbbot 1+ 2dup at cols 1- sp>col at
restcursor ;
: up_dbline ( -- )
ipprev2 =: ipprev
( up arrow ) dboff 1- 0max =: dboff ;
: down_dbline ( -- )
ipprev2 =: ipprev
( down arrow ) incr> dboff ;
\ **************************************************************************
\ Additional MINI help for the debugger.
\ **************************************************************************
: show_help ( -- )
ipprev2 =: ipprev
savecursor cursor-off savescr
0 5 59 19 box&fill
bcr ." Debugger commands:" bcr
bcr ." \S04\1 SPACE \0 = Do a single instruction"
bcr ." \S04\1 ESC \0 = Done, terminate debugger"
bcr ." \S04\1 D \0 = Done, continue execution from break point"
bcr ." \S04\1 G \0 = Go till hilighted line"
bcr ." \S04\1 R \0 = Set a Register"
bcr
bcr ." \1 Press ESC to continue, or SPACE for more help "
key $1B <>
if
0 5 59 19 box&fill
bcr ." Using R, \`<number> =AX\` will set AX to <number>."
bcr ." Registers that can be set are:"
bcr ." =CS =DS =ES =SS =IP =SI =DI =SP =BP =AX =BX =CX =DX"
bcr
bcr ." TRACE gives registers CS, DS, SS, ES, IP, and AX"
bcr ." default values. Use TRACE once, then use 'R' to set"
bcr ." registers to your desired values."
bcr bcr ." \S10\1 Press ANY key to continue " key drop
then
restscr restcursor ;
\ **************************************************************************
\ the main trace loop, walks through instructions until the ESC key is
\ pressed.
\ **************************************************************************
: do_dbkey ( c1 -- f1 )
case
( terminate ) $1B of true endof
( enter ) $0D of single_step false endof
( space ) $20 of single_step false endof
( up arrow ) $C8 of up_dbline false endof
( down arrow ) $D0 of down_dbline false endof
( help ) $BB of show_help false endof
upc \ remaining tests are case insensitive
( Go ) 'G' of break_point false endof
( register set) 'R' of set_register false endof
( debug done ) 'D' of 0 20 at trace_done false endof
ipprev2 =: ipprev
( all others ) drop beep false
endcase ;
: steps ( -- )
.dbheader
0 20 at
rp@ =bp
rp@ 80 - rp! \ move return stack out of the way
sp@ =sp \ set debugger to Forth stack
sp@ 20 - sp!
begin show_debug
key do_dbkey
until sp0 @ sp-@ - 2/ 0> \ is stack empty?
if sp-@ sp! \ if not, restore it
else sp0 @ sp! \ else clear stack
then
debugbp @ rp! .dbfooter ;
' steps is do_steps \ link into break point handler
\ **************************************************************************
\ setup for tracing a series of instructions, and call STEPS.
\ **************************************************************************
: trace ( | <name> -- ) \ use as in: TRACE <word> <enter>
\ sets up and displays first
\ instruction with registers.
' dup =ip =ax
?cs: dup =cs dup =ds =ss
?es: =es
off> dboff
off> ipprev
steps ;
\ ***************************************************************************
\ some test words for the debugger
\ ***************************************************************************
code tst ( -- )
mov ax, # 23
push ax
next end-code
cr .( try: TRACE TST <enter> )
: ++ + ;
: test 2 3 ++ . ;
.( try: BREAKAT ++ <enter> )
.( then: TEST <enter> )
cr
\ **************************************************************************
\ A utility to allow dropping into the BXDEBUG program while testing this
\ debugger
\ **************************************************************************
\ code int3 ( -- ) \ a debugging tool
\ int 3
\ next end-code
}
