Annotation of gforth/debug.fs, revision 1.3

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

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