Annotation of gforth/debug.fs, revision 1.10

1.1       anton       1: \ DEBUG.FS     Debugger                                12jun93jaw
                      2: 
1.9       anton       3: \ Copyright (C) 1995,1996,1997 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
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
1.1       anton      21: decimal
                     22: 
1.8       jwilke     23: VARIABLE dbg-ip     \ istruction pointer for debugger
1.1       anton      24: 
                     25: : scanword ( body -- )
                     26:         c-init C-Output off
                     27:         ScanMode c-pass !
                     28:         dup MakePass
                     29:         0 Level !
                     30:         0 XPos !
                     31:         DisplayMode c-pass !
                     32:         MakePass
                     33:         C-Output on ;
                     34: 
                     35: : .n    0 <# # # # # #S #> ctype bl cemit ;
                     36: 
                     37: : d.s   ." [ " depth . ." ] "
                     38:         depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
                     39: 
                     40: : NoFine        XPos off YPos off
                     41:                 NLFlag off Level off
                     42:                 C-Formated off
                     43:                 ;
                     44: 
                     45: : disp-step
                     46:         DisplayMode c-pass !            \ change to displaymode
                     47:         cr
                     48:         c-stop off
1.8       jwilke     49:         Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
1.1       anton      50:         Base !
                     51:         NoFine 10 XPos !
1.8       jwilke     52:         dbg-ip @ DisplayMode c-pass ! Analyse drop
1.1       anton      53:         25 XPos @ - 0 max spaces ." -> " ;
                     54: 
                     55: : get-next ( -- n | n n )
                     56:         DebugMode c-pass !
1.8       jwilke     57:         dbg-ip @ Analyse ;
1.1       anton      58: 
                     59: : jump          ( addr -- )
                     60:                 r> drop \ discard last ip
                     61:                 >r ;
                     62: 
                     63: AVARIABLE DebugLoop
                     64: 
1.8       jwilke     65: : breaker      r> 1 cells - dbg-ip ! DebugLoop @ jump ;
1.1       anton      66: 
                     67: CREATE BP 0 , 0 ,
                     68: CREATE DT 0 , 0 ,
                     69: 
                     70: : set-bp        ( 0 n | 0 n n -- )
                     71:                 0. BP 2!
                     72:                 ?dup IF dup BP ! dup @ DT !
                     73:                         ['] Breaker swap !
                     74:                         ?dup IF dup BP cell+ ! dup @ DT cell+ !
                     75:                                 ['] Breaker swap ! drop THEN
                     76:                      THEN ;
                     77: 
                     78: : restore-bp    ( -- )
                     79:                 BP @ ?dup IF DT @ swap ! THEN
                     80:                 BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
                     81: 
                     82: VARIABLE Body
                     83: 
                     84: : NestXT        ( xt -- true | body false )
1.10    ! jwilke     85:                \ special deal for create does> words
        !            86:                \ leaves body address on the stack
        !            87:                dup >does-code IF dup >body swap THEN
        !            88: 
1.1       anton      89:                 DebugMode c-pass ! C-Output off
1.5       anton      90:                 xt-see C-Output on
1.1       anton      91:                 c-pass @ DebugMode = dup
                     92:                 IF      ." Cannot debug" cr
                     93:                 THEN ;         
                     94: 
                     95: VARIABLE Nesting
                     96: 
                     97: : Leave-D
                     98:                 C-Formated on
                     99:                 C-Output on ;
                    100: 
                    101: VARIABLE Unnest
                    102: 
                    103: : D-KEY         ( -- flag )
                    104:         BEGIN
                    105:                 Unnest @ IF 0 ELSE key THEN
1.8       jwilke    106:                 CASE    [char] n OF     dbg-ip @ @ NestXT EXIT ENDOF
1.1       anton     107:                         [char] s OF     Leave-D
                    108:                                         -128 THROW ENDOF
                    109:                         [char] a OF     Leave-D
                    110:                                         -128 THROW ENDOF
                    111:                         [char] d OF     Leave-D
                    112:                                         cr ." Done..." cr
                    113:                                         Nesting off
1.8       jwilke    114:                                         r> drop dbg-ip @ >r
1.1       anton     115:                                         EXIT ENDOF
                    116:                         [char] ? OF     cr ." Nest Stop Done Unnest" cr
                    117:                                         ENDOF
                    118:                         [char] u OF     Unnest on true EXIT ENDOF
                    119:                         drop true EXIT
                    120:                 ENDCASE
                    121:         AGAIN ;
                    122: 
                    123: : (debug) ( body -- )
                    124:         0 Nesting !
                    125:         BEGIN   Unnest off
                    126:                 cr ." Scanning code..." cr C-Formated on
1.8       jwilke    127:                 dup scanword dbg-ip !
1.1       anton     128:                 cr ." Nesting debugger ready!" cr
1.10    ! jwilke    129:                 BEGIN   d.s disp-step D-Key
1.1       anton     130:                 WHILE   C-Stop @ 0=
                    131:                 WHILE   0 get-next set-bp
1.8       jwilke    132:                         dbg-ip @ jump
1.1       anton     133:                         [ here DebugLoop ! ]
                    134:                         restore-bp
                    135:                 REPEAT
1.8       jwilke    136:                 Nesting @ 0= IF EXIT THEN
1.1       anton     137:                 -1 Nesting +! r>
                    138:                 ELSE
1.8       jwilke    139:                 dbg-ip @ 1 cells + >r 1 Nesting +!
1.1       anton     140:                 THEN
                    141:         AGAIN ;
                    142: 
1.8       jwilke    143: : dbg   ' NestXT IF EXIT THEN (debug) Leave-D ;
1.1       anton     144: 
1.7       jwilke    145: : break:
                    146:         r> ['] (debug) >body >r ;
1.6       anton     147: 
1.7       jwilke    148: : (break")
1.6       anton     149:         cr
                    150:         ." BREAK AT: " type cr
1.7       jwilke    151:         r> ['] (debug) >body >r ;
1.6       anton     152: 
1.7       jwilke    153: : break"
1.6       anton     154:         postpone s"
1.7       jwilke    155:         postpone (break") ; immediate

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