version 1.5, 1996/08/26 10:07:18
|
version 1.23, 2003/03/22 10:04:06
|
Line 1
|
Line 1
|
\ DEBUG.FS Debugger 12jun93jaw |
\ DEBUG.FS Debugger 12jun93jaw |
|
|
\ Copyright (C) 1995 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,2000,2003 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 16
|
Line 16
|
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program; if not, write to the Free Software |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
decimal |
require see.fs |
|
|
VARIABLE IP \ istruction pointer for debugger |
|
|
|
\ Formated debugger words 12jun93jaw |
|
|
|
false [IF] |
|
|
|
Color: Men# |
|
<A red >b yellow >f bold A> Men# CT! |
|
|
|
CREATE D-LineIP 80 cells allot |
|
CREATE D-XPos 300 chars allot align |
|
CREATE D-LineA 80 cells allot |
|
VARIABLE ^LineA |
|
|
|
VARIABLE D-Lines |
|
VARIABLE D-Line |
|
VARIABLE D-MaxLines 10 D-MaxLines ! |
|
VARIABLE D-Bugline |
|
|
|
: WatcherInit |
|
D-MaxLines @ 3 + YPos ! 0 D-Line ! ; |
|
|
|
: (lines) |
|
1 cells ^LineA +! |
|
O-PNT@ ^LineA @ ! ; |
|
|
|
VARIABLE Body |
|
|
|
: ScanWord ( body -- ) |
decimal |
dup body ! |
|
c-init |
|
ScanMode c-pass ! |
|
C-Formated on 0 Level ! |
|
C-ClearLine on |
|
Colors on |
|
0 XPos ! 0 YPos ! |
|
O-INIT |
|
dup MakePass |
|
DisplayMode c-pass ! |
|
c-stop off |
|
D-LineIP 80 cells erase |
|
0 D-Lines ! dup D-LineIP ! |
|
O-PNT@ D-LineA ! D-LineA ^LineA ! |
|
['] (lines) IS nlcount |
|
XPos @ D-XPos c! |
|
BEGIN analyse |
|
D-Lines @ YPos @ <> |
|
IF YPos @ D-Lines ! |
|
dup YPos @ cells D-LineIP + ! |
|
THEN |
|
XPos @ over Body @ - 0 1 cells um/mod nip chars |
|
D-XPos + c! |
|
C-Stop @ |
|
UNTIL drop |
|
O-PNT@ YPos @ 1+ cells D-LineA + ! |
|
-1 YPos @ 1+ cells D-LineIP + ! |
|
O-DEINIT |
|
C-Formated off |
|
0 D-Line ! |
|
['] noop IS nlcount ; |
|
|
|
: SearchLine ( addr -- n ) |
|
D-LineIP D-Lines @ 0 |
|
?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN |
|
cell+ |
|
LOOP 2drop 0 ; |
|
|
|
: Display ( n -- ) |
|
dup cells D-LineA + @ O-Buffer + |
|
swap D-MaxLines @ + D-Lines @ min 1+ |
|
cells D-LineA + @ O-Buffer + |
|
over - type ; |
|
|
|
\ [IFDEF] Green Colors on [THEN] |
|
\ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos ! |
|
\ D-LineIP + @ C-Stop off |
|
\ BEGIN |
|
\ [IFDEF] Green IP @ over = |
|
\ IF hig# C-Highlight ! ELSE C-Highlight off THEN |
|
\ [THEN] |
|
\ Analyse |
|
\ C-Stop @ YPos @ D-MaxLines @ u>= or |
|
\ UNTIL drop ; |
|
|
|
: TopLine |
|
0 0 at-xy |
|
Men# CT@ attr! |
|
." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr |
|
\ one step beyond |
|
0 CT@ attr! ; |
|
|
|
: BottomLine |
|
0 D-MaxLines @ 3 + at-xy |
|
Men# CT@ attr! |
|
." U-nnest D-one N-est A-bort" cr |
|
0 CT@ attr! ; |
|
|
|
VARIABLE LastIP |
|
|
|
: (supress) |
|
YPos @ D-MaxLines @ U>= |
|
IF c-output off THEN ; |
|
|
|
: DispIP |
|
['] (supress) IS nlcount |
|
dup SearchLine D-Line @ - dup YPos ! 2 + |
|
over Body @ - 0 1 cells um/mod nip chars D-XPos + c@ |
|
swap AT-XY |
|
Analyse drop |
|
['] noop IS nlcount |
|
c-output on ; |
|
|
|
: Watcher ( -- ) |
|
TopLine |
|
IP @ SearchLine dup D-Line @ dup D-MaxLines @ + |
|
within |
|
IF drop D-Line @ Display |
|
ELSE D-MaxLines @ 2/ - 0 max dup D-Line ! |
|
Display |
|
THEN |
|
C-Formated off Colors on |
|
\ LastIP @ ?DUP IF DispIP THEN |
|
Hig# C-Highlight ! |
|
IP @ DispIP IP @ LastIP ! |
|
C-Formated on C-Highlight off |
|
BottomLine ; |
|
|
|
|
VARIABLE dbg-ip \ instruction pointer for debugger |
|
|
' noop ALIAS \w immediate |
\ !! move to see? |
|
|
\ end formated debugger words |
: save-see-flags ( -- n* cnt ) |
|
C-Output @ |
|
C-Formated @ 1 ; |
|
|
[ELSE] |
: restore-see-flags ( n* cnt -- ) |
' \ alias \w immediate |
drop C-Formated ! |
|
C-Output ! ; |
|
|
: scanword ( body -- ) |
: scanword ( body -- ) |
|
>r save-see-flags r> |
c-init C-Output off |
c-init C-Output off |
ScanMode c-pass ! |
ScanMode c-pass ! |
dup MakePass |
dup MakePass |
Line 163 VARIABLE LastIP
|
Line 43 VARIABLE LastIP
|
0 XPos ! |
0 XPos ! |
DisplayMode c-pass ! |
DisplayMode c-pass ! |
MakePass |
MakePass |
C-Output on ; |
restore-see-flags ; |
[THEN] |
|
|
|
: .n 0 <# # # # # #S #> ctype bl cemit ; |
: .n 0 <# # # # # #S #> ctype bl cemit ; |
|
|
Line 174 VARIABLE LastIP
|
Line 53 VARIABLE LastIP
|
: NoFine XPos off YPos off |
: NoFine XPos off YPos off |
NLFlag off Level off |
NLFlag off Level off |
C-Formated off |
C-Formated off |
[IFDEF] Colors Colors off [THEN] |
|
; |
; |
|
|
: disp-step |
: Leave-D ; |
|
|
|
: disp-step ( -- ) |
|
\ display step at current dbg-ip |
DisplayMode c-pass ! \ change to displaymode |
DisplayMode c-pass ! \ change to displaymode |
\ Branches Off \ don't display |
|
\ \ BEGIN and THEN |
|
cr |
cr |
\w YPos @ 1+ D-BugLine ! |
|
\w Watcher |
|
c-stop off |
c-stop off |
\w 0 D-BugLine @ at-xy |
Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space |
Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space |
|
Base ! |
Base ! |
|
save-see-flags |
NoFine 10 XPos ! |
NoFine 10 XPos ! |
\w D-Bugline @ YPos ! |
dbg-ip @ DisplayMode c-pass ! Analyse drop |
ip @ DisplayMode c-pass ! Analyse drop |
25 XPos @ - 0 max spaces ." -> " |
25 XPos @ - 0 max spaces ." -> " ; |
restore-see-flags ; |
|
|
: get-next ( -- n | n n ) |
: get-next ( -- n | n n ) |
DebugMode c-pass ! |
DebugMode c-pass ! |
ip @ Analyse ; |
dbg-ip @ Analyse ; |
|
|
: jump ( addr -- ) |
: jump ( addr -- ) |
r> drop \ discard last ip |
r> drop \ discard last ip |
Line 203 VARIABLE LastIP
|
Line 80 VARIABLE LastIP
|
|
|
AVARIABLE DebugLoop |
AVARIABLE DebugLoop |
|
|
: breaker r> 1 cells - IP ! DebugLoop @ jump ; |
: breaker r> 1 cells - dbg-ip ! DebugLoop @ jump ; |
|
|
CREATE BP 0 , 0 , |
CREATE BP 0 , 0 , |
CREATE DT 0 , 0 , |
CREATE DT 0 , 0 , |
Line 222 CREATE DT 0 , 0 ,
|
Line 99 CREATE DT 0 , 0 ,
|
|
|
VARIABLE Body |
VARIABLE Body |
|
|
: NestXT ( xt -- true | body false ) |
: nestXT-checkSpecial ( xt -- xt2 | cfa xt2 ) |
DebugMode c-pass ! C-Output off |
dup >does-code IF |
xt-see C-Output on |
\ if nest into a does> we must leave |
c-pass @ DebugMode = dup |
\ the body address on stack as does> does... |
IF ." Cannot debug" cr |
dup >body swap EXIT |
THEN ; |
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 Nesting |
|
|
: Leave-D |
|
[IFDEF] Colors Colors on [THEN] |
|
C-Formated on |
|
C-Output on ; |
|
|
|
VARIABLE Unnest |
VARIABLE Unnest |
|
|
: D-KEY ( -- flag ) |
: D-KEY ( -- flag ) |
BEGIN |
BEGIN |
Unnest @ IF 0 ELSE key THEN |
Unnest @ IF 0 ELSE key THEN |
CASE [char] n OF IP @ @ NestXT EXIT ENDOF |
CASE [char] n OF dbg-ip @ @ nestXT EXIT ENDOF |
[char] s OF Leave-D |
[char] s OF Leave-D |
-128 THROW ENDOF |
-128 THROW ENDOF |
[char] a OF Leave-D |
[char] a OF Leave-D |
Line 249 VARIABLE Unnest
|
Line 147 VARIABLE Unnest
|
[char] d OF Leave-D |
[char] d OF Leave-D |
cr ." Done..." cr |
cr ." Done..." cr |
Nesting off |
Nesting off |
r> drop IP @ >r |
r> drop dbg-ip @ >r |
EXIT ENDOF |
EXIT ENDOF |
[char] ? OF cr ." Nest Stop Done Unnest" cr |
[char] ? OF cr ." Nest Stop Done Unnest" cr |
ENDOF |
ENDOF |
Line 258 VARIABLE Unnest
|
Line 156 VARIABLE Unnest
|
ENDCASE |
ENDCASE |
AGAIN ; |
AGAIN ; |
|
|
: (debug) ( body -- ) |
: (_debug) ( body ip -- ) |
0 Nesting ! |
0 Nesting ! |
BEGIN Unnest off |
BEGIN Unnest off |
cr ." Scanning code..." cr C-Formated on |
cr ." Scanning code..." cr C-Formated on |
dup scanword IP ! |
swap scanword dbg-ip ! |
cr ." Nesting debugger ready!" cr |
cr ." Nesting debugger ready!" cr |
\w WatcherInit 0 CT@ attr! page |
BEGIN d.s disp-step D-Key |
BEGIN disp-step D-Key |
|
WHILE C-Stop @ 0= |
WHILE C-Stop @ 0= |
WHILE 0 get-next set-bp |
WHILE 0 get-next set-bp |
IP @ jump |
dbg-ip @ jump |
[ here DebugLoop ! ] |
[ here DebugLoop ! ] |
restore-bp |
restore-bp |
d.s |
|
REPEAT |
REPEAT |
Nesting @ 0= ?EXIT |
Nesting @ 0= IF EXIT THEN |
-1 Nesting +! r> |
-1 Nesting +! r> |
ELSE |
ELSE |
IP @ >r 1 Nesting +! |
dbg-ip @ 1 cells + >r 1 Nesting +! |
THEN |
THEN |
|
dup |
AGAIN ; |
AGAIN ; |
|
|
: dbg ' NestXT ?EXIT (debug) Leave-D ; |
: (debug) dup (_debug) ; |
|
|
|
: dbg ( "name" -- ) \ gforth |
|
' NestXT IF EXIT THEN (debug) Leave-D ; |
|
|
|
: break:, ( -- ) |
|
latestxt postpone literal ; |
|
|
\ : test 1 2 4 swap dup . ; |
: (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 |