version 1.17, 2000/09/23 15:46:52
|
version 1.24, 2004/06/19 15:32:31
|
Line 1
|
Line 1
|
\ DEBUG.FS Debugger 12jun93jaw |
\ DEBUG.FS Debugger 12jun93jaw |
|
|
\ Copyright (C) 1995,1996,1997,2000 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 18
|
Line 18
|
\ along with this program; if not, write to the Free Software |
\ along with this program; if not, write to the Free Software |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
require see.fs |
|
|
decimal |
decimal |
|
|
VARIABLE dbg-ip \ instruction pointer for debugger |
VARIABLE dbg-ip \ instruction pointer for debugger |
Line 43 VARIABLE dbg-ip \ instruction pointe
|
Line 45 VARIABLE dbg-ip \ instruction pointe
|
MakePass |
MakePass |
restore-see-flags ; |
restore-see-flags ; |
|
|
: .n 0 <# # # # # #S #> ctype bl cemit ; |
: .n ( n -- ) 0 <# # # # # #S #> ctype bl cemit ; |
|
|
: d.s ." [ " depth . ." ] " |
|
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; |
|
|
|
: NoFine XPos off YPos off |
: d.s ( .. -- .. ) ." [ " depth . ." ] " |
NLFlag off Level off |
depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; |
C-Formated off |
|
; |
|
|
|
: Leave-D ; |
: NoFine ( -- ) |
|
XPos off YPos off |
|
NLFlag off Level off |
|
C-Formated off ; |
|
|
|
: Leave-D ( -- ) ; |
|
|
: disp-step ( -- ) |
: disp-step ( -- ) |
\ display step at current dbg-ip |
\ display step at current dbg-ip |
Line 73 VARIABLE dbg-ip \ instruction pointe
|
Line 75 VARIABLE dbg-ip \ instruction pointe
|
dbg-ip @ Analyse ; |
dbg-ip @ Analyse ; |
|
|
: jump ( addr -- ) |
: jump ( addr -- ) |
r> drop \ discard last ip |
r> drop \ discard last ip |
>r ; |
>r ; |
|
|
AVARIABLE DebugLoop |
AVARIABLE DebugLoop |
|
|
: breaker r> 1 cells - dbg-ip ! DebugLoop @ jump ; |
1 cells Constant breaker-size \ !!! dependency: ITC |
|
|
|
: breaker ( R:body -- ) |
|
r> breaker-size - dbg-ip ! DebugLoop @ jump ; |
|
|
CREATE BP 0 , 0 , |
CREATE BP 0 , 0 , |
CREATE DT 0 , 0 , |
CREATE DT 0 , 0 , |
|
|
: set-bp ( 0 n | 0 n n -- ) |
: set-bp ( 0 n | 0 n n -- ) \ !!! dependency: ITC |
0. BP 2! |
0. BP 2! |
?dup IF dup BP ! dup @ DT ! |
?dup IF dup BP ! dup @ DT ! |
['] Breaker swap ! |
['] Breaker swap ! |
Line 91 CREATE DT 0 , 0 ,
|
Line 96 CREATE DT 0 , 0 ,
|
['] Breaker swap ! drop THEN |
['] Breaker swap ! drop THEN |
THEN ; |
THEN ; |
|
|
: restore-bp ( -- ) |
: restore-bp ( -- ) \ !!! dependency: ITC |
BP @ ?dup IF DT @ swap ! THEN |
BP @ ?dup IF DT @ swap ! THEN |
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; |
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; |
|
|
VARIABLE Body |
VARIABLE Body |
|
|
: NestXT ( xt -- true | body false ) |
: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) |
\ special deal for create does> words |
dup ['] call = IF |
\ leaves body address on the stack |
drop dbg-ip @ cell+ @ body> EXIT |
dup >does-code IF dup >body swap THEN |
THEN |
|
dup >does-code IF |
DebugMode c-pass ! C-Output off |
\ if nest into a does> we must leave |
xt-see C-Output on |
\ the body address on stack as does> does... |
c-pass @ DebugMode = dup |
dup >body swap EXIT |
IF ." Cannot debug" cr |
THEN |
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 |
|
xt-see C-Output on |
|
c-pass @ DebugMode = dup |
|
IF cr ." Cannot debug!!" |
|
THEN ; |
|
|
VARIABLE Nesting |
VARIABLE Nesting |
|
|
Line 115 VARIABLE Unnest
|
Line 145 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 148 VARIABLE Unnest
|
Line 178 VARIABLE Unnest
|
Nesting @ 0= IF EXIT THEN |
Nesting @ 0= IF EXIT THEN |
-1 Nesting +! r> |
-1 Nesting +! r> |
ELSE |
ELSE |
dbg-ip @ 1 cells + >r 1 Nesting +! |
get-next >r 1 Nesting +! |
THEN |
THEN |
dup |
dup |
AGAIN ; |
AGAIN ; |
Line 159 VARIABLE Unnest
|
Line 189 VARIABLE Unnest
|
' NestXT IF EXIT THEN (debug) Leave-D ; |
' NestXT IF EXIT THEN (debug) Leave-D ; |
|
|
: break:, ( -- ) |
: break:, ( -- ) |
lastxt postpone literal ; |
latestxt postpone literal ; |
|
|
: (break:) |
: (break:) |
r> ['] (_debug) >body >r ; |
r> ['] (_debug) >body >r ; |