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