--- gforth/debug.fs 1999/02/24 11:05:16 1.10 +++ gforth/debug.fs 2007/12/31 19:02:24 1.27 @@ -1,12 +1,12 @@ \ DEBUG.FS Debugger 12jun93jaw -\ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,2000,2003,2004,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,14 +15,26 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. + +require see.fs 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 -- ) + >r save-see-flags r> c-init C-Output off ScanMode c-pass ! dup MakePass @@ -30,44 +42,52 @@ VARIABLE dbg-ip \ istruction pointer 0 XPos ! DisplayMode c-pass ! MakePass - C-Output on ; + 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 ; +: d.s ( .. -- .. ) ." [ " depth . ." ] " + depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ; -: NoFine XPos off YPos off - NLFlag off Level off - C-Formated off - ; +: NoFine ( -- ) + XPos off YPos off + NLFlag off Level off + C-Formated off ; + +: Leave-D ( -- ) ; -: disp-step +: disp-step ( -- ) +\ display step at current dbg-ip DisplayMode c-pass ! \ change to displaymode cr c-stop off Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space Base ! + save-see-flags NoFine 10 XPos ! 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 ) DebugMode c-pass ! 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 ! @@ -75,35 +95,56 @@ 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 ( xt -- true | body false ) - \ special deal for create does> words - \ leaves body address on the stack - dup >does-code IF dup >body swap THEN - - DebugMode c-pass ! C-Output off - xt-see C-Output on - c-pass @ DebugMode = dup - IF ." Cannot debug" cr - THEN ; +: 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 ; + +: 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 -: Leave-D - C-Formated on - C-Output on ; - VARIABLE Unnest : D-KEY ( -- flag ) BEGIN 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 -128 THROW ENDOF [char] a OF Leave-D @@ -120,11 +161,11 @@ VARIABLE Unnest ENDCASE AGAIN ; -: (debug) ( body -- ) +: (_debug) ( body ip -- ) 0 Nesting ! BEGIN Unnest off cr ." Scanning code..." cr C-Formated on - dup scanword dbg-ip ! + swap scanword dbg-ip ! cr ." Nesting debugger ready!" cr BEGIN d.s disp-step D-Key WHILE C-Stop @ 0= @@ -136,20 +177,31 @@ 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 ; -: dbg ' NestXT IF EXIT THEN (debug) Leave-D ; +: (debug) dup (_debug) ; -: break: - r> ['] (debug) >body >r ; +: dbg ( "name" -- ) \ gforth + ' NestXT IF EXIT THEN (debug) Leave-D ; -: (break") - cr - ." BREAK AT: " type cr - r> ['] (debug) >body >r ; +: break:, ( -- ) + latestxt postpone literal ; -: break" - postpone s" - postpone (break") ; immediate +: (break:) + r> ['] (_debug) >body >r ; + +: break: ( -- ) \ gforth + break:, postpone (break:) ; immediate + +: (break") + cr + ." BREAK AT: " type cr + r> ['] (_debug) >body >r ; + +: break" ( 'ccc"' -- ) \ gforth + break:, + postpone s" + postpone (break") ; immediate