Annotation of gforth/debug.fs, revision 1.25

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

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