Return to debug.fs CVS log

Up to [gforth] / gforth

Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

    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 . ;