Annotation of gforth/debug.fs, revision 1.27

1.1       anton       1: \ DEBUG.FS     Debugger                                12jun93jaw
                      2: 
1.27    ! anton       3: \ Copyright (C) 1995,1996,1997,2000,2003,2004,2007 Free Software Foundation, Inc.
1.4       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.26      anton       9: \ as published by the Free Software Foundation, either version 3
1.4       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.26      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.4       anton      19: 
1.19      jwilke     20: require see.fs
                     21: 
1.1       anton      22: decimal
                     23: 
1.14      crook      24: VARIABLE dbg-ip     \ instruction pointer for debugger
1.1       anton      25: 
1.15      jwilke     26: \ !! move to see?
                     27: 
                     28: : save-see-flags ( -- n* cnt )
                     29:   C-Output @
                     30:   C-Formated @ 1 ;
                     31: 
                     32: : restore-see-flags ( n* cnt -- )
                     33:   drop C-Formated !
                     34:   C-Output ! ;
                     35: 
1.1       anton      36: : scanword ( body -- )
1.15      jwilke     37:         >r save-see-flags r>
1.1       anton      38:         c-init C-Output off
                     39:         ScanMode c-pass !
                     40:         dup MakePass
                     41:         0 Level !
                     42:         0 XPos !
                     43:         DisplayMode c-pass !
                     44:         MakePass
1.15      jwilke     45:         restore-see-flags ;
1.1       anton      46: 
1.24      pazsan     47: : .n ( n -- )    0 <# # # # # #S #> ctype bl cemit ;
1.1       anton      48: 
1.24      pazsan     49: : d.s   ( .. -- .. )  ." [ " depth . ." ] "
                     50:     depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
1.1       anton      51: 
1.24      pazsan     52: : NoFine ( -- )
                     53:     XPos off YPos off
                     54:     NLFlag off Level off
                     55:     C-Formated off ;
                     56:                
                     57: : Leave-D ( -- ) ;
1.15      jwilke     58: 
                     59: : disp-step ( -- )
                     60: \ display step at current dbg-ip
1.1       anton      61:         DisplayMode c-pass !            \ change to displaymode
                     62:         cr
                     63:         c-stop off
1.8       jwilke     64:         Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
1.1       anton      65:         Base !
1.15      jwilke     66:         save-see-flags
1.1       anton      67:         NoFine 10 XPos !
1.8       jwilke     68:         dbg-ip @ DisplayMode c-pass ! Analyse drop
1.15      jwilke     69:         25 XPos @ - 0 max spaces ." -> " 
                     70:         restore-see-flags ;
1.1       anton      71: 
                     72: : get-next ( -- n | n n )
                     73:         DebugMode c-pass !
1.8       jwilke     74:         dbg-ip @ Analyse ;
1.1       anton      75: 
                     76: : jump          ( addr -- )
1.24      pazsan     77:     r> drop \ discard last ip
                     78:     >r ;
1.1       anton      79: 
                     80: AVARIABLE DebugLoop
                     81: 
1.24      pazsan     82: 1 cells Constant breaker-size \ !!! dependency: ITC
                     83: 
                     84: : breaker ( R:body -- )
                     85:     r> breaker-size - dbg-ip ! DebugLoop @ jump ;
1.1       anton      86: 
                     87: CREATE BP 0 , 0 ,
                     88: CREATE DT 0 , 0 ,
                     89: 
1.24      pazsan     90: : set-bp        ( 0 n | 0 n n -- ) \ !!! dependency: ITC
1.1       anton      91:                 0. BP 2!
                     92:                 ?dup IF dup BP ! dup @ DT !
                     93:                         ['] Breaker swap !
                     94:                         ?dup IF dup BP cell+ ! dup @ DT cell+ !
                     95:                                 ['] Breaker swap ! drop THEN
                     96:                      THEN ;
                     97: 
1.24      pazsan     98: : restore-bp    ( -- ) \ !!! dependency: ITC
                     99:     BP @ ?dup IF DT @ swap ! THEN
                    100:     BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
1.1       anton     101: 
                    102: VARIABLE Body
                    103: 
1.24      pazsan    104: : nestXT-checkSpecial ( xt -- xt2 | cfa xt2 )
                    105:     dup ['] call = IF
                    106:        drop dbg-ip @ cell+ @ body>  EXIT
                    107:     THEN
                    108:     dup >does-code IF
                    109:        \ if nest into a does> we must leave
                    110:        \ the body address on stack as does> does...
                    111:        dup >body swap EXIT
                    112:     THEN
                    113:     dup ['] EXECUTE = IF   
                    114:        \ xt to EXECUTE is next stack item...
                    115:        drop EXIT 
                    116:     THEN
                    117:     dup ['] PERFORM = IF
                    118:        \ xt to EXECUTE is addressed by next stack item
                    119:        drop @ EXIT 
                    120:     THEN
                    121:     BEGIN
                    122:        dup >code-address dodefer: =
1.18      jwilke    123:     WHILE
1.24      pazsan    124:            \ load xt of DEFERed word
                    125:            cr ." nesting defered..." 
                    126:            >body @    
                    127:     REPEAT ;
1.10      jwilke    128: 
1.18      jwilke    129: : nestXT ( xt -- true | body false )
                    130: \G return true if we are not able to debug this, 
                    131: \G body and false otherwise
                    132:   nestXT-checkSpecial 
                    133:   \ scan code with xt-see
                    134:   DebugMode c-pass ! C-Output off
                    135:   xt-see C-Output on
                    136:   c-pass @ DebugMode = dup
                    137:   IF      cr ." Cannot debug!!"
                    138:   THEN ;
1.1       anton     139: 
                    140: VARIABLE Nesting
                    141: 
                    142: VARIABLE Unnest
                    143: 
                    144: : D-KEY         ( -- flag )
                    145:         BEGIN
                    146:                 Unnest @ IF 0 ELSE key THEN
1.18      jwilke    147:                 CASE    [char] n OF     dbg-ip @ @ nestXT EXIT ENDOF
1.1       anton     148:                         [char] s OF     Leave-D
                    149:                                         -128 THROW ENDOF
                    150:                         [char] a OF     Leave-D
                    151:                                         -128 THROW ENDOF
                    152:                         [char] d OF     Leave-D
                    153:                                         cr ." Done..." cr
                    154:                                         Nesting off
1.8       jwilke    155:                                         r> drop dbg-ip @ >r
1.1       anton     156:                                         EXIT ENDOF
                    157:                         [char] ? OF     cr ." Nest Stop Done Unnest" cr
                    158:                                         ENDOF
                    159:                         [char] u OF     Unnest on true EXIT ENDOF
                    160:                         drop true EXIT
                    161:                 ENDCASE
                    162:         AGAIN ;
                    163: 
1.15      jwilke    164: : (_debug) ( body ip -- )
1.1       anton     165:         0 Nesting !
                    166:         BEGIN   Unnest off
                    167:                 cr ." Scanning code..." cr C-Formated on
1.15      jwilke    168:                 swap scanword dbg-ip !
1.1       anton     169:                 cr ." Nesting debugger ready!" cr
1.10      jwilke    170:                 BEGIN   d.s disp-step D-Key
1.1       anton     171:                 WHILE   C-Stop @ 0=
                    172:                 WHILE   0 get-next set-bp
1.8       jwilke    173:                         dbg-ip @ jump
1.1       anton     174:                         [ here DebugLoop ! ]
                    175:                         restore-bp
                    176:                 REPEAT
1.8       jwilke    177:                 Nesting @ 0= IF EXIT THEN
1.1       anton     178:                 -1 Nesting +! r>
                    179:                 ELSE
1.24      pazsan    180:                 get-next >r 1 Nesting +!
1.1       anton     181:                 THEN
1.15      jwilke    182:                 dup
1.1       anton     183:         AGAIN ;
                    184: 
1.15      jwilke    185: : (debug) dup (_debug) ;
                    186: 
1.14      crook     187: : dbg ( "name" -- ) \ gforth 
1.11      crook     188:     ' NestXT IF EXIT THEN (debug) Leave-D ;
1.1       anton     189: 
1.15      jwilke    190: : break:, ( -- )
1.23      anton     191:   latestxt postpone literal ;
1.15      jwilke    192: 
                    193: : (break:)
                    194:     r> ['] (_debug) >body >r ;
                    195:   
1.14      crook     196: : break: ( -- ) \ gforth
1.15      jwilke    197:     break:, postpone (break:) ; immediate
1.6       anton     198: 
1.7       jwilke    199: : (break")
1.11      crook     200:     cr
                    201:     ." BREAK AT: " type cr
1.15      jwilke    202:     r> ['] (_debug) >body >r ;
1.6       anton     203: 
1.14      crook     204: : break" ( 'ccc"' -- ) \ gforth
1.15      jwilke    205:     break:,
1.11      crook     206:     postpone s"
                    207:     postpone (break") ; immediate

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