File:  [gforth] / gforth / debug.fs
Revision 1.17: download - view: text, annotated - select for diffs
Sat Sep 23 15:46:52 2000 UTC (20 years, 11 months ago) by anton
Branches: MAIN
CVS tags: v0-5-0, HEAD
changed FSF address in copyright messages

    1: \ DEBUG.FS     Debugger                                12jun93jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,2000 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: decimal
   22: 
   23: VARIABLE dbg-ip     \ instruction pointer for debugger
   24: 
   25: \ !! move to see?
   26: 
   27: : save-see-flags ( -- n* cnt )
   28:   C-Output @
   29:   C-Formated @ 1 ;
   30: 
   31: : restore-see-flags ( n* cnt -- )
   32:   drop C-Formated !
   33:   C-Output ! ;
   34: 
   35: : scanword ( body -- )
   36:         >r save-see-flags r>
   37:         c-init C-Output off
   38:         ScanMode c-pass !
   39:         dup MakePass
   40:         0 Level !
   41:         0 XPos !
   42:         DisplayMode c-pass !
   43:         MakePass
   44:         restore-see-flags ;
   45: 
   46: : .n    0 <# # # # # #S #> ctype bl cemit ;
   47: 
   48: : d.s   ." [ " depth . ." ] "
   49:         depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
   50: 
   51: : NoFine        XPos off YPos off
   52:                 NLFlag off Level off
   53:                 C-Formated off
   54:                 ;
   55: 
   56: : Leave-D ;
   57: 
   58: : disp-step ( -- )
   59: \ display step at current dbg-ip
   60:         DisplayMode c-pass !            \ change to displaymode
   61:         cr
   62:         c-stop off
   63:         Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
   64:         Base !
   65:         save-see-flags
   66:         NoFine 10 XPos !
   67:         dbg-ip @ DisplayMode c-pass ! Analyse drop
   68:         25 XPos @ - 0 max spaces ." -> " 
   69:         restore-see-flags ;
   70: 
   71: : get-next ( -- n | n n )
   72:         DebugMode c-pass !
   73:         dbg-ip @ Analyse ;
   74: 
   75: : jump          ( addr -- )
   76:                 r> drop \ discard last ip
   77:                 >r ;
   78: 
   79: AVARIABLE DebugLoop
   80: 
   81: : breaker      r> 1 cells - dbg-ip ! DebugLoop @ jump ;
   82: 
   83: CREATE BP 0 , 0 ,
   84: CREATE DT 0 , 0 ,
   85: 
   86: : set-bp        ( 0 n | 0 n n -- )
   87:                 0. BP 2!
   88:                 ?dup IF dup BP ! dup @ DT !
   89:                         ['] Breaker swap !
   90:                         ?dup IF dup BP cell+ ! dup @ DT cell+ !
   91:                                 ['] Breaker swap ! drop THEN
   92:                      THEN ;
   93: 
   94: : restore-bp    ( -- )
   95:                 BP @ ?dup IF DT @ swap ! THEN
   96:                 BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
   97: 
   98: VARIABLE Body
   99: 
  100: : NestXT        ( xt -- true | body false )
  101: 		\ special deal for create does> words
  102: 		\ leaves body address on the stack
  103: 		dup >does-code IF dup >body swap THEN
  104: 
  105:                 DebugMode c-pass ! C-Output off
  106:                 xt-see C-Output on
  107:                 c-pass @ DebugMode = dup
  108:                 IF      ." Cannot debug" cr
  109:                 THEN ;         
  110: 
  111: VARIABLE Nesting
  112: 
  113: VARIABLE Unnest
  114: 
  115: : D-KEY         ( -- flag )
  116:         BEGIN
  117:                 Unnest @ IF 0 ELSE key THEN
  118:                 CASE    [char] n OF     dbg-ip @ @ NestXT EXIT ENDOF
  119:                         [char] s OF     Leave-D
  120:                                         -128 THROW ENDOF
  121:                         [char] a OF     Leave-D
  122:                                         -128 THROW ENDOF
  123:                         [char] d OF     Leave-D
  124:                                         cr ." Done..." cr
  125:                                         Nesting off
  126:                                         r> drop dbg-ip @ >r
  127:                                         EXIT ENDOF
  128:                         [char] ? OF     cr ." Nest Stop Done Unnest" cr
  129:                                         ENDOF
  130:                         [char] u OF     Unnest on true EXIT ENDOF
  131:                         drop true EXIT
  132:                 ENDCASE
  133:         AGAIN ;
  134: 
  135: : (_debug) ( body ip -- )
  136:         0 Nesting !
  137:         BEGIN   Unnest off
  138:                 cr ." Scanning code..." cr C-Formated on
  139:                 swap scanword dbg-ip !
  140:                 cr ." Nesting debugger ready!" cr
  141:                 BEGIN   d.s disp-step D-Key
  142:                 WHILE   C-Stop @ 0=
  143:                 WHILE   0 get-next set-bp
  144:                         dbg-ip @ jump
  145:                         [ here DebugLoop ! ]
  146:                         restore-bp
  147:                 REPEAT
  148:                 Nesting @ 0= IF EXIT THEN
  149:                 -1 Nesting +! r>
  150:                 ELSE
  151:                 dbg-ip @ 1 cells + >r 1 Nesting +!
  152:                 THEN
  153:                 dup
  154:         AGAIN ;
  155: 
  156: : (debug) dup (_debug) ;
  157: 
  158: : dbg ( "name" -- ) \ gforth 
  159:     ' NestXT IF EXIT THEN (debug) Leave-D ;
  160: 
  161: : break:, ( -- )
  162:   lastxt postpone literal ;
  163: 
  164: : (break:)
  165:     r> ['] (_debug) >body >r ;
  166:   
  167: : break: ( -- ) \ gforth
  168:     break:, postpone (break:) ; immediate
  169: 
  170: : (break")
  171:     cr
  172:     ." BREAK AT: " type cr
  173:     r> ['] (_debug) >body >r ;
  174: 
  175: : break" ( 'ccc"' -- ) \ gforth
  176:     break:,
  177:     postpone s"
  178:     postpone (break") ; immediate

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