Diff for /gforth/debug.fs between versions 1.18 and 1.24

version 1.18, 2000/11/12 18:34:39 version 1.24, 2004/06/19 15:32:31
Line 1 Line 1
 \ DEBUG.FS     Debugger                                12jun93jaw  \ DEBUG.FS     Debugger                                12jun93jaw
   
 \ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 18 Line 18
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   require see.fs
   
 decimal  decimal
   
 VARIABLE dbg-ip     \ instruction pointer for debugger  VARIABLE dbg-ip     \ instruction pointer for debugger
Line 43  VARIABLE dbg-ip     \ instruction pointe Line 45  VARIABLE dbg-ip     \ instruction pointe
         MakePass          MakePass
         restore-see-flags ;          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 ;  
   
 : NoFine        XPos off YPos off  : d.s   ( .. -- .. )  ." [ " depth . ." ] "
                 NLFlag off Level off      depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
                 C-Formated off  
                 ;  
   
 : Leave-D ;  : NoFine ( -- )
       XPos off YPos off
       NLFlag off Level off
       C-Formated off ;
                   
   : Leave-D ( -- ) ;
   
 : disp-step ( -- )  : disp-step ( -- )
 \ display step at current dbg-ip  \ display step at current dbg-ip
Line 73  VARIABLE dbg-ip     \ instruction pointe Line 75  VARIABLE dbg-ip     \ instruction pointe
         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 91  CREATE DT 0 , 0 , Line 96  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-checkSpecial ( xt -- xt2 | cfa xt2 )   : nestXT-checkSpecial ( xt -- xt2 | cfa xt2 )
   dup >does-code IF      dup ['] call = IF
     \ if nest into a does> we must leave          drop dbg-ip @ cell+ @ body>  EXIT
     \ the body address on stack as does> does...      THEN
     dup >body swap EXIT      dup >does-code IF
   THEN          \ if nest into a does> we must leave
   dup ['] EXECUTE = IF             \ the body address on stack as does> does...
     \ xt to EXECUTE is next stack item...          dup >body swap EXIT
     drop EXIT       THEN
   THEN      dup ['] EXECUTE = IF   
   dup ['] PERFORM = IF          \ xt to EXECUTE is next stack item...
     \ xt to EXECUTE is addressed by next stack item          drop EXIT 
     drop @ EXIT       THEN
   THEN      dup ['] PERFORM = IF
   BEGIN          \ xt to EXECUTE is addressed by next stack item
     dup >code-address dodefer: =          drop @ EXIT 
       THEN
       BEGIN
           dup >code-address dodefer: =
     WHILE      WHILE
       \ load xt of DEFERed word              \ load xt of DEFERed word
       cr ." nesting defered..."               cr ." nesting defered..." 
       >body @                  >body @    
   REPEAT ;      REPEAT ;
   
 : nestXT ( xt -- true | body false )  : nestXT ( xt -- true | body false )
 \G return true if we are not able to debug this,   \G return true if we are not able to debug this, 
Line 170  VARIABLE Unnest Line 178  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                  dup
         AGAIN ;          AGAIN ;
Line 181  VARIABLE Unnest Line 189  VARIABLE Unnest
     ' NestXT IF EXIT THEN (debug) Leave-D ;      ' NestXT IF EXIT THEN (debug) Leave-D ;
   
 : break:, ( -- )  : break:, ( -- )
   lastxt postpone literal ;    latestxt postpone literal ;
   
 : (break:)  : (break:)
     r> ['] (_debug) >body >r ;      r> ['] (_debug) >body >r ;

Removed from v.1.18  
changed lines
  Added in v.1.24


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