[BACK]Return to debug.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/debug.fs between versions 1.10 and 1.26

version 1.10, 1999/02/24 11:05:16 version 1.26, 2007/12/31 18:40:23
Line 1 Line 1
 \ DEBUG.FS     Debugger                                12jun93jaw  \ DEBUG.FS     Debugger                                12jun93jaw
   
 \ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,2000,2003,2004 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ 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.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ 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, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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
Line 30  VARIABLE dbg-ip     \ istruction pointer Line 42  VARIABLE dbg-ip     \ istruction pointer
         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 ( n -- )    0 <# # # # # #S #> ctype bl cemit ;
   
 : d.s   ." [ " depth . ." ] "  : d.s   ( .. -- .. )  ." [ " depth . ." ] "
         depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;      depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
   
 : NoFine        XPos off YPos off  : NoFine ( -- )
                 NLFlag off Level off      XPos off YPos off
                 C-Formated 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          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 !
         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 75  CREATE DT 0 , 0 , Line 95  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
   
 : 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
Line 120  VARIABLE Unnest Line 161  VARIABLE Unnest
                 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=
Line 136  VARIABLE Unnest Line 177  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
         AGAIN ;          AGAIN ;
   
 : dbg   ' NestXT IF EXIT THEN (debug) Leave-D ;  : (debug) dup (_debug) ;
   
 : break:  : dbg ( "name" -- ) \ gforth 
         r> ['] (debug) >body >r ;      ' NestXT IF EXIT THEN (debug) Leave-D ;
   
 : (break")  : break:, ( -- )
         cr    latestxt postpone literal ;
         ." BREAK AT: " type cr  
         r> ['] (debug) >body >r ;  
   
 : break"  : (break:)
         postpone s"      r> ['] (_debug) >body >r ;
         postpone (break") ; immediate    
   : 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
Removed from v.1.10  
changed lines
  Added in v.1.26

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>