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