File:  [gforth] / gforth / debug.fs
Revision 1.1: download - view: text, annotated - select for diffs
Fri Feb 11 16:30:45 1994 UTC (30 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
Initial revision

    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: 
  265: : dbg   ' NestXT ?EXIT (debug) ;
  266: 
  267: : test 1 2 4 swap dup . ;

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