| \ DEBUG.FS Debugger 12jun93jaw |
\ DEBUG.FS Debugger 12jun93jaw |
| |
|
| \ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. |
\ Copyright (C) 1995-2003 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| |
|
| \ 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 |
| 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 ; |
| |
|
| 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 ! |
| |
|
| 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 |
| |
THEN |
| |
dup ['] EXECUTE = IF |
| |
\ xt to EXECUTE is next stack item... |
| |
drop EXIT |
| |
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 |
DebugMode c-pass ! C-Output off |
| xt-see C-Output on |
xt-see C-Output on |
| c-pass @ DebugMode = dup |
c-pass @ DebugMode = dup |
| IF ." Cannot debug" cr |
IF cr ." Cannot debug!!" |
| THEN ; |
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 |
| 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= |
| 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 ; |
| |
|
| : break: \ gforth |
: break:, ( -- ) |
| r> ['] (debug) >body >r ; |
lastxt postpone literal ; |
| |
|
| |
: (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 |
