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