version 1.12, 1999/05/20 13:31:57
|
version 1.23, 2003/03/22 10:04:06
|
Line 1
|
Line 1
|
\ DEBUG.FS Debugger 12jun93jaw |
\ DEBUG.FS Debugger 12jun93jaw |
|
|
\ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,2000,2003 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 16
|
Line 16
|
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program; if not, write to the Free Software |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
require see.fs |
|
|
decimal |
decimal |
|
|
VARIABLE dbg-ip \ istruction pointer for debugger |
VARIABLE dbg-ip \ instruction pointer for debugger |
|
|
|
\ !! move to see? |
|
|
|
: save-see-flags ( -- n* cnt ) |
|
C-Output @ |
|
C-Formated @ 1 ; |
|
|
|
: restore-see-flags ( n* cnt -- ) |
|
drop C-Formated ! |
|
C-Output ! ; |
|
|
: scanword ( body -- ) |
: scanword ( body -- ) |
|
>r save-see-flags r> |
c-init C-Output off |
c-init C-Output off |
ScanMode c-pass ! |
ScanMode c-pass ! |
dup MakePass |
dup MakePass |
Line 30 VARIABLE dbg-ip \ istruction pointer
|
Line 43 VARIABLE dbg-ip \ istruction pointer
|
0 XPos ! |
0 XPos ! |
DisplayMode c-pass ! |
DisplayMode c-pass ! |
MakePass |
MakePass |
C-Output on ; |
restore-see-flags ; |
|
|
: .n 0 <# # # # # #S #> ctype bl cemit ; |
: .n 0 <# # # # # #S #> ctype bl cemit ; |
|
|
Line 42 VARIABLE dbg-ip \ istruction pointer
|
Line 55 VARIABLE dbg-ip \ istruction pointer
|
C-Formated off |
C-Formated off |
; |
; |
|
|
: disp-step |
: Leave-D ; |
|
|
|
: disp-step ( -- ) |
|
\ display step at current dbg-ip |
DisplayMode c-pass ! \ change to displaymode |
DisplayMode c-pass ! \ change to displaymode |
cr |
cr |
c-stop off |
c-stop off |
Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space |
Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space |
Base ! |
Base ! |
|
save-see-flags |
NoFine 10 XPos ! |
NoFine 10 XPos ! |
dbg-ip @ DisplayMode c-pass ! Analyse drop |
dbg-ip @ DisplayMode c-pass ! Analyse drop |
25 XPos @ - 0 max spaces ." -> " ; |
25 XPos @ - 0 max spaces ." -> " |
|
restore-see-flags ; |
|
|
: get-next ( -- n | n n ) |
: get-next ( -- n | n n ) |
DebugMode c-pass ! |
DebugMode c-pass ! |
Line 81 CREATE DT 0 , 0 ,
|
Line 99 CREATE DT 0 , 0 ,
|
|
|
VARIABLE Body |
VARIABLE Body |
|
|
: NestXT ( xt -- true | body false ) |
: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) |
\ special deal for create does> words |
dup >does-code IF |
\ leaves body address on the stack |
\ if nest into a does> we must leave |
dup >does-code IF dup >body swap THEN |
\ the body address on stack as does> does... |
|
dup >body swap EXIT |
DebugMode c-pass ! C-Output off |
THEN |
xt-see C-Output on |
dup ['] EXECUTE = IF |
c-pass @ DebugMode = dup |
\ xt to EXECUTE is next stack item... |
IF ." Cannot debug" cr |
drop EXIT |
THEN ; |
THEN |
|
dup ['] PERFORM = IF |
|
\ xt to EXECUTE is addressed by next stack item |
|
drop @ EXIT |
|
THEN |
|
BEGIN |
|
dup >code-address dodefer: = |
|
WHILE |
|
\ load xt of DEFERed word |
|
cr ." nesting defered..." |
|
>body @ |
|
REPEAT ; |
|
|
|
: nestXT ( xt -- true | body false ) |
|
\G return true if we are not able to debug this, |
|
\G body and false otherwise |
|
nestXT-checkSpecial |
|
\ scan code with xt-see |
|
DebugMode c-pass ! C-Output off |
|
xt-see C-Output on |
|
c-pass @ DebugMode = dup |
|
IF cr ." Cannot debug!!" |
|
THEN ; |
|
|
VARIABLE Nesting |
VARIABLE Nesting |
|
|
: Leave-D |
|
C-Formated on |
|
C-Output on ; |
|
|
|
VARIABLE Unnest |
VARIABLE Unnest |
|
|
: D-KEY ( -- flag ) |
: D-KEY ( -- flag ) |
BEGIN |
BEGIN |
Unnest @ IF 0 ELSE key THEN |
Unnest @ IF 0 ELSE key THEN |
CASE [char] n OF dbg-ip @ @ NestXT EXIT ENDOF |
CASE [char] n OF dbg-ip @ @ nestXT EXIT ENDOF |
[char] s OF Leave-D |
[char] s OF Leave-D |
-128 THROW ENDOF |
-128 THROW ENDOF |
[char] a OF Leave-D |
[char] a OF Leave-D |
Line 120 VARIABLE Unnest
|
Line 156 VARIABLE Unnest
|
ENDCASE |
ENDCASE |
AGAIN ; |
AGAIN ; |
|
|
: (debug) ( body -- ) |
: (_debug) ( body ip -- ) |
0 Nesting ! |
0 Nesting ! |
BEGIN Unnest off |
BEGIN Unnest off |
cr ." Scanning code..." cr C-Formated on |
cr ." Scanning code..." cr C-Formated on |
dup scanword dbg-ip ! |
swap scanword dbg-ip ! |
cr ." Nesting debugger ready!" cr |
cr ." Nesting debugger ready!" cr |
BEGIN d.s disp-step D-Key |
BEGIN d.s disp-step D-Key |
WHILE C-Stop @ 0= |
WHILE C-Stop @ 0= |
Line 138 VARIABLE Unnest
|
Line 174 VARIABLE Unnest
|
ELSE |
ELSE |
dbg-ip @ 1 cells + >r 1 Nesting +! |
dbg-ip @ 1 cells + >r 1 Nesting +! |
THEN |
THEN |
|
dup |
AGAIN ; |
AGAIN ; |
|
|
: dbg \ gforth |
: (debug) dup (_debug) ; |
|
|
|
: dbg ( "name" -- ) \ gforth |
' NestXT IF EXIT THEN (debug) Leave-D ; |
' NestXT IF EXIT THEN (debug) Leave-D ; |
|
|
has? compiler [IF] |
: break:, ( -- ) |
: break: \ gforth |
latestxt postpone literal ; |
r> ['] (debug) >body >r ; |
|
|
: (break:) |
|
r> ['] (_debug) >body >r ; |
|
|
|
: break: ( -- ) \ gforth |
|
break:, postpone (break:) ; immediate |
|
|
: (break") |
: (break") |
cr |
cr |
." BREAK AT: " type cr |
." BREAK AT: " type cr |
r> ['] (debug) >body >r ; |
r> ['] (_debug) >body >r ; |
|
|
: break" \ gforth |
: break" ( 'ccc"' -- ) \ gforth |
|
break:, |
postpone s" |
postpone s" |
postpone (break") ; immediate |
postpone (break") ; immediate |
[THEN] |
|
|
|