Annotation of gforth/debug.fs, revision 1.25
1.1 anton 1: \ DEBUG.FS Debugger 12jun93jaw
2:
1.25 ! anton 3: \ Copyright (C) 1995,1996,1997,2000,2003,2004 Free Software Foundation, Inc.
1.4 anton 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
1.17 anton 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.4 anton 20:
1.19 jwilke 21: require see.fs
22:
1.1 anton 23: decimal
24:
1.14 crook 25: VARIABLE dbg-ip \ instruction pointer for debugger
1.1 anton 26:
1.15 jwilke 27: \ !! move to see?
28:
29: : save-see-flags ( -- n* cnt )
30: C-Output @
31: C-Formated @ 1 ;
32:
33: : restore-see-flags ( n* cnt -- )
34: drop C-Formated !
35: C-Output ! ;
36:
1.1 anton 37: : scanword ( body -- )
1.15 jwilke 38: >r save-see-flags r>
1.1 anton 39: c-init C-Output off
40: ScanMode c-pass !
41: dup MakePass
42: 0 Level !
43: 0 XPos !
44: DisplayMode c-pass !
45: MakePass
1.15 jwilke 46: restore-see-flags ;
1.1 anton 47:
1.24 pazsan 48: : .n ( n -- ) 0 <# # # # # #S #> ctype bl cemit ;
1.1 anton 49:
1.24 pazsan 50: : d.s ( .. -- .. ) ." [ " depth . ." ] "
51: depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
1.1 anton 52:
1.24 pazsan 53: : NoFine ( -- )
54: XPos off YPos off
55: NLFlag off Level off
56: C-Formated off ;
57:
58: : Leave-D ( -- ) ;
1.15 jwilke 59:
60: : disp-step ( -- )
61: \ display step at current dbg-ip
1.1 anton 62: DisplayMode c-pass ! \ change to displaymode
63: cr
64: c-stop off
1.8 jwilke 65: Base @ hex dbg-ip @ 8 u.r space dbg-ip @ @ 8 u.r space
1.1 anton 66: Base !
1.15 jwilke 67: save-see-flags
1.1 anton 68: NoFine 10 XPos !
1.8 jwilke 69: dbg-ip @ DisplayMode c-pass ! Analyse drop
1.15 jwilke 70: 25 XPos @ - 0 max spaces ." -> "
71: restore-see-flags ;
1.1 anton 72:
73: : get-next ( -- n | n n )
74: DebugMode c-pass !
1.8 jwilke 75: dbg-ip @ Analyse ;
1.1 anton 76:
77: : jump ( addr -- )
1.24 pazsan 78: r> drop \ discard last ip
79: >r ;
1.1 anton 80:
81: AVARIABLE DebugLoop
82:
1.24 pazsan 83: 1 cells Constant breaker-size \ !!! dependency: ITC
84:
85: : breaker ( R:body -- )
86: r> breaker-size - dbg-ip ! DebugLoop @ jump ;
1.1 anton 87:
88: CREATE BP 0 , 0 ,
89: CREATE DT 0 , 0 ,
90:
1.24 pazsan 91: : set-bp ( 0 n | 0 n n -- ) \ !!! dependency: ITC
1.1 anton 92: 0. BP 2!
93: ?dup IF dup BP ! dup @ DT !
94: ['] Breaker swap !
95: ?dup IF dup BP cell+ ! dup @ DT cell+ !
96: ['] Breaker swap ! drop THEN
97: THEN ;
98:
1.24 pazsan 99: : restore-bp ( -- ) \ !!! dependency: ITC
100: BP @ ?dup IF DT @ swap ! THEN
101: BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
1.1 anton 102:
103: VARIABLE Body
104:
1.24 pazsan 105: : nestXT-checkSpecial ( xt -- xt2 | cfa xt2 )
106: dup ['] call = IF
107: drop dbg-ip @ cell+ @ body> EXIT
108: THEN
109: dup >does-code IF
110: \ if nest into a does> we must leave
111: \ the body address on stack as does> does...
112: dup >body swap EXIT
113: THEN
114: dup ['] EXECUTE = IF
115: \ xt to EXECUTE is next stack item...
116: drop EXIT
117: THEN
118: dup ['] PERFORM = IF
119: \ xt to EXECUTE is addressed by next stack item
120: drop @ EXIT
121: THEN
122: BEGIN
123: dup >code-address dodefer: =
1.18 jwilke 124: WHILE
1.24 pazsan 125: \ load xt of DEFERed word
126: cr ." nesting defered..."
127: >body @
128: REPEAT ;
1.10 jwilke 129:
1.18 jwilke 130: : nestXT ( xt -- true | body false )
131: \G return true if we are not able to debug this,
132: \G body and false otherwise
133: nestXT-checkSpecial
134: \ scan code with xt-see
135: DebugMode c-pass ! C-Output off
136: xt-see C-Output on
137: c-pass @ DebugMode = dup
138: IF cr ." Cannot debug!!"
139: THEN ;
1.1 anton 140:
141: VARIABLE Nesting
142:
143: VARIABLE Unnest
144:
145: : D-KEY ( -- flag )
146: BEGIN
147: Unnest @ IF 0 ELSE key THEN
1.18 jwilke 148: CASE [char] n OF dbg-ip @ @ nestXT EXIT ENDOF
1.1 anton 149: [char] s OF Leave-D
150: -128 THROW ENDOF
151: [char] a OF Leave-D
152: -128 THROW ENDOF
153: [char] d OF Leave-D
154: cr ." Done..." cr
155: Nesting off
1.8 jwilke 156: r> drop dbg-ip @ >r
1.1 anton 157: EXIT ENDOF
158: [char] ? OF cr ." Nest Stop Done Unnest" cr
159: ENDOF
160: [char] u OF Unnest on true EXIT ENDOF
161: drop true EXIT
162: ENDCASE
163: AGAIN ;
164:
1.15 jwilke 165: : (_debug) ( body ip -- )
1.1 anton 166: 0 Nesting !
167: BEGIN Unnest off
168: cr ." Scanning code..." cr C-Formated on
1.15 jwilke 169: swap scanword dbg-ip !
1.1 anton 170: cr ." Nesting debugger ready!" cr
1.10 jwilke 171: BEGIN d.s disp-step D-Key
1.1 anton 172: WHILE C-Stop @ 0=
173: WHILE 0 get-next set-bp
1.8 jwilke 174: dbg-ip @ jump
1.1 anton 175: [ here DebugLoop ! ]
176: restore-bp
177: REPEAT
1.8 jwilke 178: Nesting @ 0= IF EXIT THEN
1.1 anton 179: -1 Nesting +! r>
180: ELSE
1.24 pazsan 181: get-next >r 1 Nesting +!
1.1 anton 182: THEN
1.15 jwilke 183: dup
1.1 anton 184: AGAIN ;
185:
1.15 jwilke 186: : (debug) dup (_debug) ;
187:
1.14 crook 188: : dbg ( "name" -- ) \ gforth
1.11 crook 189: ' NestXT IF EXIT THEN (debug) Leave-D ;
1.1 anton 190:
1.15 jwilke 191: : break:, ( -- )
1.23 anton 192: latestxt postpone literal ;
1.15 jwilke 193:
194: : (break:)
195: r> ['] (_debug) >body >r ;
196:
1.14 crook 197: : break: ( -- ) \ gforth
1.15 jwilke 198: break:, postpone (break:) ; immediate
1.6 anton 199:
1.7 jwilke 200: : (break")
1.11 crook 201: cr
202: ." BREAK AT: " type cr
1.15 jwilke 203: r> ['] (_debug) >body >r ;
1.6 anton 204:
1.14 crook 205: : break" ( 'ccc"' -- ) \ gforth
1.15 jwilke 206: break:,
1.11 crook 207: postpone s"
208: postpone (break") ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>