Return to debug.fs CVS log

Up to [gforth] / gforth

updated copyright years for files changed in 2004

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