Annotation of gforth/debug.fs, revision 1.5

1.1       anton       1: \ DEBUG.FS     Debugger                                12jun93jaw
                      2: 
1.4       anton       3: \ Copyright (C) 1995 Free Software Foundation, Inc.
                      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: 
                     23: VARIABLE IP     \ istruction pointer for debugger
                     24: 
                     25: \ Formated debugger words                               12jun93jaw
                     26: 
                     27: false [IF]
                     28: 
                     29: Color: Men#
                     30: <A red >b yellow >f bold A> Men# CT!
                     31: 
                     32: CREATE D-LineIP 80 cells allot
                     33: CREATE D-XPos   300 chars allot align
                     34: CREATE D-LineA  80 cells allot
                     35: VARIABLE ^LineA
                     36: 
                     37: VARIABLE D-Lines
                     38: VARIABLE D-Line
                     39: VARIABLE D-MaxLines 10 D-MaxLines !
                     40: VARIABLE D-Bugline
                     41: 
                     42: : WatcherInit
                     43:         D-MaxLines @ 3 + YPos ! 0 D-Line ! ;
                     44: 
                     45: : (lines)
                     46:         1 cells ^LineA +!
                     47:         O-PNT@ ^LineA @ ! ;
                     48: 
                     49: VARIABLE Body
                     50: 
                     51: : ScanWord ( body -- )
                     52:         dup body !
                     53:         c-init
                     54:         ScanMode c-pass !
                     55:         C-Formated on   0 Level !
                     56:         C-ClearLine on
                     57:         Colors on
                     58:         0 XPos ! 0 YPos !
                     59:         O-INIT
                     60:         dup MakePass
                     61:         DisplayMode c-pass !
                     62:         c-stop off
                     63:         D-LineIP 80 cells erase
                     64:         0 D-Lines ! dup D-LineIP !
                     65:         O-PNT@ D-LineA ! D-LineA ^LineA !
                     66:         ['] (lines) IS nlcount
                     67:         XPos @ D-XPos c!
                     68:         BEGIN   analyse
                     69:                 D-Lines @ YPos @ <>
                     70:                 IF      YPos @ D-Lines !
                     71:                         dup YPos @ cells D-LineIP + !
                     72:                 THEN
                     73:                 XPos @ over Body @ - 0 1 cells um/mod nip chars
                     74:                 D-XPos + c!
                     75:                 C-Stop @
                     76:         UNTIL drop
                     77:         O-PNT@ YPos @ 1+ cells D-LineA + !
                     78:         -1 YPos @ 1+ cells D-LineIP + !
                     79:         O-DEINIT
                     80:         C-Formated off
                     81:         0 D-Line !
                     82:         ['] noop IS nlcount ;
                     83: 
                     84: : SearchLine ( addr -- n )
                     85:         D-LineIP D-Lines @ 0
                     86:         ?DO     dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN
                     87:                 cell+
                     88:         LOOP    2drop 0 ;
                     89: 
                     90: : Display ( n -- )
                     91:         dup cells D-LineA + @ O-Buffer +
                     92:         swap D-MaxLines @ + D-Lines @ min 1+
                     93:              cells D-LineA + @ O-Buffer +
                     94:         over - type ;
                     95: 
                     96: \ [IFDEF] Green Colors on [THEN]
                     97: \        dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos !
                     98: \        D-LineIP + @ C-Stop off
                     99: \        BEGIN
                    100: \        [IFDEF] Green IP @ over =
                    101: \                IF hig# C-Highlight ! ELSE C-Highlight off THEN
                    102: \        [THEN]
                    103: \                Analyse
                    104: \                C-Stop @ YPos @ D-MaxLines @ u>= or
                    105: \        UNTIL   drop ;
                    106: 
                    107: : TopLine
                    108:         0 0 at-xy
                    109:         Men# CT@ attr!
                    110:         ." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr
                    111:         \ one step beyond
                    112:         0 CT@ attr! ;
                    113: 
                    114: : BottomLine
                    115:         0 D-MaxLines @ 3 + at-xy
                    116:         Men# CT@ attr!
                    117:         ." U-nnest D-one N-est A-bort" cr
                    118:         0 CT@ attr! ;
                    119: 
                    120: VARIABLE LastIP
                    121: 
                    122: : (supress)
                    123:         YPos @ D-MaxLines @ U>=
                    124:         IF c-output off THEN ;
                    125: 
                    126: : DispIP
                    127:         ['] (supress) IS nlcount
                    128:         dup SearchLine D-Line @ - dup YPos ! 2 +
                    129:         over Body @ - 0 1 cells um/mod nip chars D-XPos + c@
                    130:         swap AT-XY
                    131:         Analyse drop
                    132:         ['] noop IS nlcount
                    133:         c-output on ;
                    134: 
                    135: : Watcher ( -- )
                    136:         TopLine
                    137:         IP @ SearchLine dup D-Line @ dup D-MaxLines @ +
                    138:         within
                    139:         IF      drop D-Line @ Display
                    140:         ELSE    D-MaxLines @ 2/ - 0 max dup D-Line !
                    141:                 Display
                    142:         THEN
                    143:         C-Formated off Colors on
                    144: \        LastIP @ ?DUP IF DispIP THEN
                    145:         Hig# C-Highlight !
                    146:         IP @ DispIP IP @ LastIP !
                    147:         C-Formated on C-Highlight off
                    148:         BottomLine ;
                    149: 
                    150: 
                    151: ' noop ALIAS \w immediate
                    152: 
                    153: \ end formated debugger words
                    154: 
                    155: [ELSE]
                    156: ' \ alias \w immediate
                    157: 
                    158: : scanword ( body -- )
                    159:         c-init C-Output off
                    160:         ScanMode c-pass !
                    161:         dup MakePass
                    162:         0 Level !
                    163:         0 XPos !
                    164:         DisplayMode c-pass !
                    165:         MakePass
                    166:         C-Output on ;
                    167: [THEN]
                    168: 
                    169: : .n    0 <# # # # # #S #> ctype bl cemit ;
                    170: 
                    171: : d.s   ." [ " depth . ." ] "
                    172:         depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
                    173: 
                    174: : NoFine        XPos off YPos off
                    175:                 NLFlag off Level off
                    176:                 C-Formated off
                    177: [IFDEF] Colors  Colors off [THEN]
                    178:                 ;
                    179: 
                    180: : disp-step
                    181:         DisplayMode c-pass !            \ change to displaymode
                    182: \       Branches Off                    \ don't display
                    183: \                                       \ BEGIN and THEN
                    184:         cr
                    185: \w      YPos @ 1+ D-BugLine !
                    186: \w      Watcher
                    187:         c-stop off
                    188: \w      0 D-BugLine @ at-xy
                    189:         Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space
                    190:         Base !
                    191:         NoFine 10 XPos !
                    192: \w      D-Bugline @ YPos !
                    193:         ip @ DisplayMode c-pass ! Analyse drop
                    194:         25 XPos @ - 0 max spaces ." -> " ;
                    195: 
                    196: : get-next ( -- n | n n )
                    197:         DebugMode c-pass !
                    198:         ip @ Analyse ;
                    199: 
                    200: : jump          ( addr -- )
                    201:                 r> drop \ discard last ip
                    202:                 >r ;
                    203: 
                    204: AVARIABLE DebugLoop
                    205: 
                    206: : breaker      r> 1 cells - IP ! DebugLoop @ jump ;
                    207: 
                    208: CREATE BP 0 , 0 ,
                    209: CREATE DT 0 , 0 ,
                    210: 
                    211: : set-bp        ( 0 n | 0 n n -- )
                    212:                 0. BP 2!
                    213:                 ?dup IF dup BP ! dup @ DT !
                    214:                         ['] Breaker swap !
                    215:                         ?dup IF dup BP cell+ ! dup @ DT cell+ !
                    216:                                 ['] Breaker swap ! drop THEN
                    217:                      THEN ;
                    218: 
                    219: : restore-bp    ( -- )
                    220:                 BP @ ?dup IF DT @ swap ! THEN
                    221:                 BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
                    222: 
                    223: VARIABLE Body
                    224: 
                    225: : NestXT        ( xt -- true | body false )
                    226:                 DebugMode c-pass ! C-Output off
1.5     ! anton     227:                 xt-see C-Output on
1.1       anton     228:                 c-pass @ DebugMode = dup
                    229:                 IF      ." Cannot debug" cr
                    230:                 THEN ;         
                    231: 
                    232: VARIABLE Nesting
                    233: 
                    234: : Leave-D
                    235: [IFDEF] Colors  Colors on [THEN]
                    236:                 C-Formated on
                    237:                 C-Output on ;
                    238: 
                    239: VARIABLE Unnest
                    240: 
                    241: : D-KEY         ( -- flag )
                    242:         BEGIN
                    243:                 Unnest @ IF 0 ELSE key THEN
                    244:                 CASE    [char] n OF     IP @ @ NestXT EXIT ENDOF
                    245:                         [char] s OF     Leave-D
                    246:                                         -128 THROW ENDOF
                    247:                         [char] a OF     Leave-D
                    248:                                         -128 THROW ENDOF
                    249:                         [char] d OF     Leave-D
                    250:                                         cr ." Done..." cr
                    251:                                         Nesting off
                    252:                                         r> drop IP @ >r
                    253:                                         EXIT ENDOF
                    254:                         [char] ? OF     cr ." Nest Stop Done Unnest" cr
                    255:                                         ENDOF
                    256:                         [char] u OF     Unnest on true EXIT ENDOF
                    257:                         drop true EXIT
                    258:                 ENDCASE
                    259:         AGAIN ;
                    260: 
                    261: : (debug) ( body -- )
                    262:         0 Nesting !
                    263:         BEGIN   Unnest off
                    264:                 cr ." Scanning code..." cr C-Formated on
                    265:                 dup scanword IP !
                    266:                 cr ." Nesting debugger ready!" cr
                    267:                 \w WatcherInit 0 CT@ attr! page
                    268:                 BEGIN   disp-step D-Key
                    269:                 WHILE   C-Stop @ 0=
                    270:                 WHILE   0 get-next set-bp
                    271:                         IP @ jump
                    272:                         [ here DebugLoop ! ]
                    273:                         restore-bp
                    274:                         d.s
                    275:                 REPEAT
                    276:                 Nesting @ 0= ?EXIT
                    277:                 -1 Nesting +! r>
                    278:                 ELSE
                    279:                 IP @ >r 1 Nesting +!
                    280:                 THEN
                    281:         AGAIN ;
                    282: 
1.3       pazsan    283: : dbg   ' NestXT ?EXIT (debug) Leave-D ;
1.1       anton     284: 
1.2       pazsan    285: \ : test 1 2 4 swap dup . ;

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