Return to debug.fs CVS log

Up to [gforth] / gforth

updated copyright year after changing license notice

    1: \ DEBUG.FS     Debugger                                12jun93jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,2000,2003,2004,2007 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   20: require see.fs
   21: 
   22: decimal
   23: 
   24: VARIABLE dbg-ip     \ instruction pointer for debugger
   25: 
   26: \ !! move to see?
   27: 
   28: : save-see-flags ( -- n* cnt )
   29:   C-Output @
   30:   C-Formated @ 1 ;
   31: 
   32: : restore-see-flags ( n* cnt -- )
   33:   drop C-Formated !
   34:   C-Output ! ;
   35: 
   36: : scanword ( body -- )
   37:         >r save-see-flags r>
   38:         c-init C-Output off
   39:         ScanMode c-pass !
   40:         dup MakePass
   41:         0 Level !
   42:         0 XPos !
   43:         DisplayMode c-pass !
   44:         MakePass
   45:         restore-see-flags ;
   46: 
   47: : .n ( n -- )    0 <# # # # # #S #> ctype bl cemit ;
   48: 
   49: : d.s   ( .. -- .. )  ." [ " depth . ." ] "
   50:     depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
   51: 
   52: : NoFine ( -- )
   53:     XPos off YPos off
   54:     NLFlag off Level off
   55:     C-Formated off ;
   56: 		
   57: : Leave-D ( -- ) ;
   58: 
   59: : disp-step ( -- )
   60: \ display step at current dbg-ip
   61:         DisplayMode c-pass !            \ change to displaymode
   62:         cr
   63:         c-stop off
   64:         Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
   65:         Base !
   66:         save-see-flags
   67:         NoFine 10 XPos !
   68:         dbg-ip @ DisplayMode c-pass ! Analyse drop
   69:         25 XPos @ - 0 max spaces ." -> " 
   70:         restore-see-flags ;
   71: 
   72: : get-next ( -- n | n n )
   73:         DebugMode c-pass !
   74:         dbg-ip @ Analyse ;
   75: 
   76: : jump          ( addr -- )
   77:     r> drop \ discard last ip
   78:     >r ;
   79: 
   80: AVARIABLE DebugLoop
   81: 
   82: 1 cells Constant breaker-size \ !!! dependency: ITC
   83: 
   84: : breaker ( R:body -- )
   85:     r> breaker-size - dbg-ip ! DebugLoop @ jump ;
   86: 
   87: CREATE BP 0 , 0 ,
   88: CREATE DT 0 , 0 ,
   89: 
   90: : set-bp        ( 0 n | 0 n n -- ) \ !!! dependency: ITC
   91:                 0. BP 2!
   92:                 ?dup IF dup BP ! dup @ DT !
   93:                         ['] Breaker swap !
   94:                         ?dup IF dup BP cell+ ! dup @ DT cell+ !
   95:                                 ['] Breaker swap ! drop THEN
   96:                      THEN ;
   97: 
   98: : restore-bp    ( -- ) \ !!! dependency: ITC
   99:     BP @ ?dup IF DT @ swap ! THEN
  100:     BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
  101: 
  102: VARIABLE Body
  103: 
  104: : nestXT-checkSpecial ( xt -- xt2 | cfa xt2 )
  105:     dup ['] call = IF
  106: 	drop dbg-ip @ cell+ @ body>  EXIT
  107:     THEN
  108:     dup >does-code IF
  109: 	\ if nest into a does> we must leave
  110: 	\ the body address on stack as does> does...
  111: 	dup >body swap EXIT
  112:     THEN
  113:     dup ['] EXECUTE = IF   
  114: 	\ xt to EXECUTE is next stack item...
  115: 	drop EXIT 
  116:     THEN
  117:     dup ['] PERFORM = IF
  118: 	\ xt to EXECUTE is addressed by next stack item
  119: 	drop @ EXIT 
  120:     THEN
  121:     BEGIN
  122: 	dup >code-address dodefer: =
  123:     WHILE
  124: 	    \ load xt of DEFERed word
  125: 	    cr ." nesting defered..." 
  126: 	    >body @    
  127:     REPEAT ;
  128: 
  129: : nestXT ( xt -- true | body false )
  130: \G return true if we are not able to debug this, 
  131: \G body and false otherwise
  132:   nestXT-checkSpecial 
  133:   \ scan code with xt-see
  134:   DebugMode c-pass ! C-Output off
  135:   xt-see C-Output on
  136:   c-pass @ DebugMode = dup
  137:   IF      cr ." Cannot debug!!"
  138:   THEN ;
  139: 
  140: VARIABLE Nesting
  141: 
  142: VARIABLE Unnest
  143: 
  144: : D-KEY         ( -- flag )
  145:         BEGIN
  146:                 Unnest @ IF 0 ELSE key THEN
  147:                 CASE    [char] n OF     dbg-ip @ @ nestXT EXIT ENDOF
  148:                         [char] s OF     Leave-D
  149:                                         -128 THROW ENDOF
  150:                         [char] a OF     Leave-D
  151:                                         -128 THROW ENDOF
  152:                         [char] d OF     Leave-D
  153:                                         cr ." Done..." cr
  154:                                         Nesting off
  155:                                         r> drop dbg-ip @ >r
  156:                                         EXIT ENDOF
  157:                         [char] ? OF     cr ." Nest Stop Done Unnest" cr
  158:                                         ENDOF
  159:                         [char] u OF     Unnest on true EXIT ENDOF
  160:                         drop true EXIT
  161:                 ENDCASE
  162:         AGAIN ;
  163: 
  164: : (_debug) ( body ip -- )
  165:         0 Nesting !
  166:         BEGIN   Unnest off
  167:                 cr ." Scanning code..." cr C-Formated on
  168:                 swap scanword dbg-ip !
  169:                 cr ." Nesting debugger ready!" cr
  170:                 BEGIN   d.s disp-step D-Key
  171:                 WHILE   C-Stop @ 0=
  172:                 WHILE   0 get-next set-bp
  173:                         dbg-ip @ jump
  174:                         [ here DebugLoop ! ]
  175:                         restore-bp
  176:                 REPEAT
  177:                 Nesting @ 0= IF EXIT THEN
  178:                 -1 Nesting +! r>
  179:                 ELSE
  180:                 get-next >r 1 Nesting +!
  181:                 THEN
  182:                 dup
  183:         AGAIN ;
  184: 
  185: : (debug) dup (_debug) ;
  186: 
  187: : dbg ( "name" -- ) \ gforth 
  188:     ' NestXT IF EXIT THEN (debug) Leave-D ;
  189: 
  190: : break:, ( -- )
  191:   latestxt postpone literal ;
  192: 
  193: : (break:)
  194:     r> ['] (_debug) >body >r ;
  195:   
  196: : break: ( -- ) \ gforth
  197:     break:, postpone (break:) ; immediate
  198: 
  199: : (break")
  200:     cr
  201:     ." BREAK AT: " type cr
  202:     r> ['] (_debug) >body >r ;
  203: 
  204: : break" ( 'ccc"' -- ) \ gforth
  205:     break:,
  206:     postpone s"
  207:     postpone (break") ; immediate