\ DEBUG.FS Debugger 12jun93jaw
\ Copyright (C) 1995 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 2
\ 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, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
decimal
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 -- )
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 ;
' noop ALIAS \w immediate
\ end formated debugger words
[ELSE]
' \ alias \w immediate
: scanword ( body -- )
c-init C-Output off
ScanMode c-pass !
dup MakePass
0 Level !
0 XPos !
DisplayMode c-pass !
MakePass
C-Output on ;
[THEN]
: .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
[IFDEF] Colors Colors off [THEN]
;
: disp-step
DisplayMode c-pass ! \ change to displaymode
\ Branches Off \ don't display
\ \ BEGIN and THEN
cr
\w YPos @ 1+ D-BugLine !
\w Watcher
c-stop off
\w 0 D-BugLine @ at-xy
Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space
Base !
NoFine 10 XPos !
\w D-Bugline @ YPos !
ip @ DisplayMode c-pass ! Analyse drop
25 XPos @ - 0 max spaces ." -> " ;
: get-next ( -- n | n n )
DebugMode c-pass !
ip @ Analyse ;
: jump ( addr -- )
r> drop \ discard last ip
>r ;
AVARIABLE DebugLoop
: breaker r> 1 cells - IP ! DebugLoop @ jump ;
CREATE BP 0 , 0 ,
CREATE DT 0 , 0 ,
: set-bp ( 0 n | 0 n n -- )
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 ( -- )
BP @ ?dup IF DT @ swap ! THEN
BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
VARIABLE Body
: NestXT ( xt -- true | body false )
DebugMode c-pass ! C-Output off
xtc C-Output on
c-pass @ DebugMode = dup
IF ." Cannot debug" cr
THEN ;
VARIABLE Nesting
: Leave-D
[IFDEF] Colors Colors on [THEN]
C-Formated on
C-Output on ;
VARIABLE Unnest
: D-KEY ( -- flag )
BEGIN
Unnest @ IF 0 ELSE key THEN
CASE [char] n OF 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 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 -- )
0 Nesting !
BEGIN Unnest off
cr ." Scanning code..." cr C-Formated on
dup scanword IP !
cr ." Nesting debugger ready!" cr
\w WatcherInit 0 CT@ attr! page
BEGIN disp-step D-Key
WHILE C-Stop @ 0=
WHILE 0 get-next set-bp
IP @ jump
[ here DebugLoop ! ]
restore-bp
d.s
REPEAT
Nesting @ 0= ?EXIT
-1 Nesting +! r>
ELSE
IP @ >r 1 Nesting +!
THEN
AGAIN ;
: dbg ' NestXT ?EXIT (debug) Leave-D ;
\ : test 1 2 4 swap dup . ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>