[gforth] / gforth / debug.fs  

gforth: gforth/debug.fs

Diff for /gforth/debug.fs between version 1.6 and 1.18

version 1.6, Wed May 21 20:39:22 1997 UTC version 1.18, Sun Nov 12 18:34:39 2000 UTC
Line 1 
Line 1 
 \ DEBUG.FS     Debugger                                12jun93jaw  \ 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.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ 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, 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  decimal
   
 VARIABLE IP     \ istruction pointer for debugger  VARIABLE dbg-ip     \ instruction pointer for debugger
   
 \ Formated debugger words                               12jun93jaw  \ !! move to see?
   
 false [IF]  : save-see-flags ( -- n* cnt )
     C-Output @
     C-Formated @ 1 ;
   
 Color: Men#  : restore-see-flags ( n* cnt -- )
 <A red >b yellow >f bold A> Men# CT!    drop C-Formated !
     C-Output ! ;
 CREATE D-LineIP 80 cells allot  
 CREATE D-XPos   300 chars allot align  
 CREATE D-LineA  80 cells allot  
 VARIABLE ^LineA  
   
 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 ;  
   
   
 ' noop ALIAS \w immediate  
   
 \ end formated debugger words  
   
 [ELSE]  
 ' \ alias \w immediate  
   
 : 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 163 
Line 41 
         0 XPos !          0 XPos !
         DisplayMode c-pass !          DisplayMode c-pass !
         MakePass          MakePass
         C-Output on ;          restore-see-flags ;
 [THEN]  
   
 : .n    0 <# # # # # #S #> ctype bl cemit ;  : .n    0 <# # # # # #S #> ctype bl cemit ;
   
Line 174 
Line 51 
 : NoFine        XPos off YPos off  : NoFine        XPos off YPos off
                 NLFlag off Level off                  NLFlag off Level off
                 C-Formated 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          DisplayMode c-pass !            \ change to displaymode
 \       Branches Off                    \ don't display  
 \                                       \ BEGIN and THEN  
         cr          cr
 \w      YPos @ 1+ D-BugLine !  
 \w      Watcher  
         c-stop off          c-stop off
 \w      0 D-BugLine @ at-xy          Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
         Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space  
         Base !          Base !
           save-see-flags
         NoFine 10 XPos !          NoFine 10 XPos !
 \w      D-Bugline @ YPos !          dbg-ip @ DisplayMode c-pass ! Analyse drop
         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 !
         ip @ Analyse ;          dbg-ip @ Analyse ;
   
 : jump          ( addr -- )  : jump          ( addr -- )
                 r> drop \ discard last ip                  r> drop \ discard last ip
Line 203 
Line 78 
   
 AVARIABLE DebugLoop  AVARIABLE DebugLoop
   
 : breaker      r> 1 cells - IP ! DebugLoop @ jump ;  : breaker      r> 1 cells - dbg-ip ! DebugLoop @ jump ;
   
 CREATE BP 0 , 0 ,  CREATE BP 0 , 0 ,
 CREATE DT 0 , 0 ,  CREATE DT 0 , 0 ,
Line 222 
Line 97 
   
 VARIABLE Body  VARIABLE Body
   
 : NestXT        ( xt -- true | body false )  : 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                  DebugMode c-pass ! C-Output off
                 xt-see C-Output on                  xt-see C-Output on
                 c-pass @ DebugMode = dup                  c-pass @ DebugMode = dup
                 IF      ." Cannot debug" cr    IF      cr ." Cannot debug!!"
                 THEN ;                  THEN ;
   
 VARIABLE Nesting  VARIABLE Nesting
   
 : Leave-D  
 [IFDEF] Colors  Colors on [THEN]  
                 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     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 249 
Line 145 
                         [char] d OF     Leave-D                          [char] d OF     Leave-D
                                         cr ." Done..." cr                                          cr ." Done..." cr
                                         Nesting off                                          Nesting off
                                         r> drop IP @ >r                                          r> drop dbg-ip @ >r
                                         EXIT ENDOF                                          EXIT ENDOF
                         [char] ? OF     cr ." Nest Stop Done Unnest" cr                          [char] ? OF     cr ." Nest Stop Done Unnest" cr
                                         ENDOF                                          ENDOF
Line 258 
Line 154 
                 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 IP !                  swap scanword dbg-ip !
                 cr ." Nesting debugger ready!" cr                  cr ." Nesting debugger ready!" cr
                 \w WatcherInit 0 CT@ attr! page                  BEGIN   d.s disp-step D-Key
                 BEGIN   disp-step D-Key  
                 WHILE   C-Stop @ 0=                  WHILE   C-Stop @ 0=
                 WHILE   0 get-next set-bp                  WHILE   0 get-next set-bp
                         IP @ jump                          dbg-ip @ jump
                         [ here DebugLoop ! ]                          [ here DebugLoop ! ]
                         restore-bp                          restore-bp
                         d.s  
                 REPEAT                  REPEAT
                 Nesting @ 0= ?EXIT                  Nesting @ 0= IF EXIT THEN
                 -1 Nesting +! r>                  -1 Nesting +! r>
                 ELSE                  ELSE
                 IP @ 1 cells + >r 1 Nesting +!                  dbg-ip @ 1 cells + >r 1 Nesting +!
                 THEN                  THEN
                   dup
         AGAIN ;          AGAIN ;
   
 : dbg   ' NestXT ?EXIT (debug) Leave-D ;  : (debug) dup (_debug) ;
   
   : dbg ( "name" -- ) \ gforth
       ' NestXT IF EXIT THEN (debug) Leave-D ;
   
   : break:, ( -- )
     lastxt postpone literal ;
   
   : (break:)
       r> ['] (_debug) >body >r ;
   
 : TRACE:  : break: ( -- ) \ gforth
         r> (debug) ;      break:, postpone (break:) ; immediate
   
 : (TRACE")  : (break")
         cr          cr
         ." BREAK AT: " type cr          ." BREAK AT: " type cr
         r> (debug) ;      r> ['] (_debug) >body >r ;
   
 : TRACE"  : break" ( 'ccc"' -- ) \ gforth
       break:,
         postpone s"          postpone s"
         postpone (TRACE") ; immediate      postpone (break") ; immediate

Generate output suitable for use with a patch program
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.18
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help