File:  [gforth] / gforth / debug.fs
Revision 1.9: download - view: text, annotated - select for diffs
Tue Dec 8 22:02:38 1998 UTC (22 years, 10 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c

    1: \ DEBUG.FS     Debugger                                12jun93jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997 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: 
   21: decimal
   22: 
   23: VARIABLE dbg-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 dbg-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:         dbg-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:         dbg-ip @ DispIP dbg-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: \      YPos @ 1+ D-BugLine !
  186: \ w      Watcher
  187:         c-stop off
  188: \ w     0 D-BugLine @ at-xy
  189:         Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
  190:         Base !
  191:         NoFine 10 XPos !
  192: \ w      D-Bugline @ YPos !
  193:         dbg-ip @ DisplayMode c-pass ! Analyse drop
  194:         25 XPos @ - 0 max spaces ." -> " ;
  195: 
  196: : get-next ( -- n | n n )
  197:         DebugMode c-pass !
  198:         dbg-ip @ Analyse ;
  199: 
  200: : jump          ( addr -- )
  201:                 r> drop \ discard last ip
  202:                 >r ;
  203: 
  204: AVARIABLE DebugLoop
  205: 
  206: : breaker      r> 1 cells - dbg-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
  227:                 xt-see C-Output on
  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     dbg-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 dbg-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 dbg-ip !
  266:                 cr ." Nesting debugger ready!" cr
  267:                 \ WatcherInit 0 CT@ attr! page
  268:                 BEGIN   disp-step D-Key
  269:                 WHILE   C-Stop @ 0=
  270:                 WHILE   0 get-next set-bp
  271:                         dbg-ip @ jump
  272:                         [ here DebugLoop ! ]
  273:                         restore-bp
  274:                         d.s
  275:                 REPEAT
  276:                 Nesting @ 0= IF EXIT THEN
  277:                 -1 Nesting +! r>
  278:                 ELSE
  279:                 dbg-ip @ 1 cells + >r 1 Nesting +!
  280:                 THEN
  281:         AGAIN ;
  282: 
  283: : dbg   ' NestXT IF EXIT THEN (debug) Leave-D ;
  284: 
  285: : break:
  286:         r> ['] (debug) >body >r ;
  287: 
  288: : (break")
  289:         cr
  290:         ." BREAK AT: " type cr
  291:         r> ['] (debug) >body >r ;
  292: 
  293: : break"
  294:         postpone s"
  295:         postpone (break") ; immediate

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