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