--- gforth/debug.fs 2000/11/12 18:34:39 1.18 +++ gforth/debug.fs 2004/12/31 13:23:56 1.25 @@ -1,6 +1,6 @@ \ DEBUG.FS Debugger 12jun93jaw -\ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,2000,2003,2004 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -18,6 +18,8 @@ \ along with this program; if not, write to the Free Software \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +require see.fs + decimal VARIABLE dbg-ip \ instruction pointer for debugger @@ -43,17 +45,17 @@ VARIABLE dbg-ip \ instruction pointe MakePass restore-see-flags ; -: .n 0 <# # # # # #S #> ctype bl cemit ; - -: d.s ." [ " depth . ." ] " - depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; +: .n ( n -- ) 0 <# # # # # #S #> ctype bl cemit ; -: NoFine XPos off YPos off - NLFlag off Level off - C-Formated off - ; +: d.s ( .. -- .. ) ." [ " depth . ." ] " + depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; -: Leave-D ; +: NoFine ( -- ) + XPos off YPos off + NLFlag off Level off + C-Formated off ; + +: Leave-D ( -- ) ; : disp-step ( -- ) \ display step at current dbg-ip @@ -73,17 +75,20 @@ VARIABLE dbg-ip \ instruction pointe dbg-ip @ Analyse ; : jump ( addr -- ) - r> drop \ discard last ip - >r ; + r> drop \ discard last ip + >r ; 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 DT 0 , 0 , -: set-bp ( 0 n | 0 n n -- ) +: set-bp ( 0 n | 0 n n -- ) \ !!! dependency: ITC 0. BP 2! ?dup IF dup BP ! dup @ DT ! ['] Breaker swap ! @@ -91,33 +96,36 @@ CREATE DT 0 , 0 , ['] Breaker swap ! drop THEN THEN ; -: restore-bp ( -- ) - BP @ ?dup IF DT @ swap ! THEN - BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; +: restore-bp ( -- ) \ !!! dependency: ITC + BP @ ?dup IF DT @ swap ! THEN + BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ; VARIABLE Body -: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) - dup >does-code IF - \ if nest into a does> we must leave - \ 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: = +: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) + dup ['] call = IF + drop dbg-ip @ cell+ @ body> EXIT + THEN + dup >does-code IF + \ if nest into a does> we must leave + \ 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 ; + \ 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, @@ -170,7 +178,7 @@ VARIABLE Unnest Nesting @ 0= IF EXIT THEN -1 Nesting +! r> ELSE - dbg-ip @ 1 cells + >r 1 Nesting +! + get-next >r 1 Nesting +! THEN dup AGAIN ; @@ -181,7 +189,7 @@ VARIABLE Unnest ' NestXT IF EXIT THEN (debug) Leave-D ; : break:, ( -- ) - lastxt postpone literal ; + latestxt postpone literal ; : (break:) r> ['] (_debug) >body >r ;