--- gforth/debug.fs 1997/06/01 20:50:38 1.7 +++ gforth/debug.fs 2003/01/20 17:07:37 1.21 @@ -1,6 +1,6 @@ \ DEBUG.FS Debugger 12jun93jaw -\ Copyright (C) 1995 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -16,146 +16,26 @@ \ 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. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. -decimal - -VARIABLE IP \ istruction pointer for debugger - -\ Formated debugger words 12jun93jaw - -false [IF] - -Color: Men# -b yellow >f bold A> Men# CT! - -CREATE D-LineIP 80 cells allot -CREATE D-XPos 300 chars allot align -CREATE D-LineA 80 cells allot -VARIABLE ^LineA +require see.fs -VARIABLE D-Lines -VARIABLE D-Line -VARIABLE D-MaxLines 10 D-MaxLines ! -VARIABLE D-Bugline - -: WatcherInit - D-MaxLines @ 3 + YPos ! 0 D-Line ! ; - -: (lines) - 1 cells ^LineA +! - O-PNT@ ^LineA @ ! ; - -VARIABLE Body - -: ScanWord ( body -- ) - dup body ! - c-init - ScanMode c-pass ! - C-Formated on 0 Level ! - C-ClearLine on - Colors on - 0 XPos ! 0 YPos ! - O-INIT - dup MakePass - DisplayMode c-pass ! - c-stop off - D-LineIP 80 cells erase - 0 D-Lines ! dup D-LineIP ! - O-PNT@ D-LineA ! D-LineA ^LineA ! - ['] (lines) IS nlcount - XPos @ D-XPos c! - BEGIN analyse - D-Lines @ YPos @ <> - IF YPos @ D-Lines ! - dup YPos @ cells D-LineIP + ! - THEN - XPos @ over Body @ - 0 1 cells um/mod nip chars - D-XPos + c! - C-Stop @ - UNTIL drop - O-PNT@ YPos @ 1+ cells D-LineA + ! - -1 YPos @ 1+ cells D-LineIP + ! - O-DEINIT - C-Formated off - 0 D-Line ! - ['] noop IS nlcount ; - -: SearchLine ( addr -- n ) - D-LineIP D-Lines @ 0 - ?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN - cell+ - LOOP 2drop 0 ; - -: Display ( n -- ) - dup cells D-LineA + @ O-Buffer + - swap D-MaxLines @ + D-Lines @ min 1+ - cells D-LineA + @ O-Buffer + - over - type ; - -\ [IFDEF] Green Colors on [THEN] -\ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos ! -\ D-LineIP + @ C-Stop off -\ BEGIN -\ [IFDEF] Green IP @ over = -\ IF hig# C-Highlight ! ELSE C-Highlight off THEN -\ [THEN] -\ Analyse -\ C-Stop @ YPos @ D-MaxLines @ u>= or -\ UNTIL drop ; - -: TopLine - 0 0 at-xy - Men# CT@ attr! - ." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr - \ one step beyond - 0 CT@ attr! ; - -: BottomLine - 0 D-MaxLines @ 3 + at-xy - Men# CT@ attr! - ." U-nnest D-one N-est A-bort" cr - 0 CT@ attr! ; - -VARIABLE LastIP - -: (supress) - YPos @ D-MaxLines @ U>= - IF c-output off THEN ; - -: DispIP - ['] (supress) IS nlcount - dup SearchLine D-Line @ - dup YPos ! 2 + - over Body @ - 0 1 cells um/mod nip chars D-XPos + c@ - swap AT-XY - Analyse drop - ['] noop IS nlcount - c-output on ; - -: Watcher ( -- ) - TopLine - IP @ SearchLine dup D-Line @ dup D-MaxLines @ + - within - IF drop D-Line @ Display - ELSE D-MaxLines @ 2/ - 0 max dup D-Line ! - Display - THEN - C-Formated off Colors on -\ LastIP @ ?DUP IF DispIP THEN - Hig# C-Highlight ! - IP @ DispIP IP @ LastIP ! - C-Formated on C-Highlight off - BottomLine ; +decimal +VARIABLE dbg-ip \ instruction pointer for debugger -' noop ALIAS \w immediate +\ !! move to see? -\ end formated debugger words +: save-see-flags ( -- n* cnt ) + C-Output @ + C-Formated @ 1 ; -[ELSE] -' \ alias \w immediate +: 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 @@ -163,8 +43,7 @@ VARIABLE LastIP 0 XPos ! DisplayMode c-pass ! MakePass - C-Output on ; -[THEN] + restore-see-flags ; : .n 0 <# # # # # #S #> ctype bl cemit ; @@ -174,28 +53,26 @@ VARIABLE LastIP : NoFine XPos off YPos off NLFlag off Level off C-Formated off -[IFDEF] Colors Colors off [THEN] ; -: disp-step +: Leave-D ; + +: disp-step ( -- ) +\ display step at current dbg-ip DisplayMode c-pass ! \ change to displaymode -\ Branches Off \ don't display -\ \ BEGIN and THEN cr -\w YPos @ 1+ D-BugLine ! -\w Watcher c-stop off -\w 0 D-BugLine @ at-xy - Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space + Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space Base ! + save-see-flags NoFine 10 XPos ! -\w D-Bugline @ YPos ! - ip @ DisplayMode c-pass ! Analyse drop - 25 XPos @ - 0 max spaces ." -> " ; + dbg-ip @ DisplayMode c-pass ! Analyse drop + 25 XPos @ - 0 max spaces ." -> " + restore-see-flags ; : get-next ( -- n | n n ) DebugMode c-pass ! - ip @ Analyse ; + dbg-ip @ Analyse ; : jump ( addr -- ) r> drop \ discard last ip @@ -203,7 +80,7 @@ VARIABLE LastIP AVARIABLE DebugLoop -: breaker r> 1 cells - IP ! DebugLoop @ jump ; +: breaker r> 1 cells - dbg-ip ! DebugLoop @ jump ; CREATE BP 0 , 0 , CREATE DT 0 , 0 , @@ -222,26 +99,47 @@ CREATE DT 0 , 0 , VARIABLE Body -: NestXT ( xt -- true | body false ) - 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 >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 -[IFDEF] Colors Colors on [THEN] - C-Formated on - C-Output on ; - VARIABLE Unnest : D-KEY ( -- flag ) BEGIN Unnest @ IF 0 ELSE key THEN - CASE [char] n OF 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 @@ -249,7 +147,7 @@ VARIABLE Unnest [char] d OF Leave-D cr ." Done..." cr Nesting off - r> drop IP @ >r + r> drop dbg-ip @ >r EXIT ENDOF [char] ? OF cr ." Nest Stop Done Unnest" cr ENDOF @@ -258,38 +156,47 @@ VARIABLE Unnest ENDCASE AGAIN ; -: (debug) ( body -- ) +: (_debug) ( body ip -- ) 0 Nesting ! BEGIN Unnest off cr ." Scanning code..." cr C-Formated on - dup scanword IP ! + swap scanword dbg-ip ! cr ." Nesting debugger ready!" cr - \w WatcherInit 0 CT@ attr! page - BEGIN disp-step D-Key + BEGIN d.s disp-step D-Key WHILE C-Stop @ 0= WHILE 0 get-next set-bp - IP @ jump + dbg-ip @ jump [ here DebugLoop ! ] restore-bp - d.s REPEAT - Nesting @ 0= ?EXIT + Nesting @ 0= IF EXIT THEN -1 Nesting +! r> ELSE - IP @ 1 cells + >r 1 Nesting +! + dbg-ip @ 1 cells + >r 1 Nesting +! THEN + dup AGAIN ; -: dbg ' NestXT ?EXIT (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:, ( -- ) + lastxt 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