Return to debug.fs CVS log

Up to [gforth] / gforth

Made some things optional. Perhaps in works sometimes without compiler,
just for debugging...

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