![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to debug.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth|
Return to debug.fs CVS log | Up to [gforth] / gforth |
1.1 anton 1: \ DEBUG.FS Debugger 12jun93jaw
2:
1.4 anton 3: \ Copyright (C) 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
1.1 anton 21: decimal
22:
23: VARIABLE IP \ istruction pointer for debugger
24:
25: \ Formated debugger words 12jun93jaw
26:
27: false [IF]
28:
29: Color: Men#
30: <A red >b yellow >f bold A> Men# CT!
31:
32: CREATE D-LineIP 80 cells allot
33: CREATE D-XPos 300 chars allot align
34: CREATE D-LineA 80 cells allot
35: VARIABLE ^LineA
36:
37: VARIABLE D-Lines
38: VARIABLE D-Line
39: VARIABLE D-MaxLines 10 D-MaxLines !
40: VARIABLE D-Bugline
41:
42: : WatcherInit
43: D-MaxLines @ 3 + YPos ! 0 D-Line ! ;
44:
45: : (lines)
46: 1 cells ^LineA +!
47: O-PNT@ ^LineA @ ! ;
48:
49: VARIABLE Body
50:
51: : ScanWord ( body -- )
52: dup body !
53: c-init
54: ScanMode c-pass !
55: C-Formated on 0 Level !
56: C-ClearLine on
57: Colors on
58: 0 XPos ! 0 YPos !
59: O-INIT
60: dup MakePass
61: DisplayMode c-pass !
62: c-stop off
63: D-LineIP 80 cells erase
64: 0 D-Lines ! dup D-LineIP !
65: O-PNT@ D-LineA ! D-LineA ^LineA !
66: ['] (lines) IS nlcount
67: XPos @ D-XPos c!
68: BEGIN analyse
69: D-Lines @ YPos @ <>
70: IF YPos @ D-Lines !
71: dup YPos @ cells D-LineIP + !
72: THEN
73: XPos @ over Body @ - 0 1 cells um/mod nip chars
74: D-XPos + c!
75: C-Stop @
76: UNTIL drop
77: O-PNT@ YPos @ 1+ cells D-LineA + !
78: -1 YPos @ 1+ cells D-LineIP + !
79: O-DEINIT
80: C-Formated off
81: 0 D-Line !
82: ['] noop IS nlcount ;
83:
84: : SearchLine ( addr -- n )
85: D-LineIP D-Lines @ 0
86: ?DO dup @ 2 pick U> IF 2drop I 1- UNLOOP EXIT THEN
87: cell+
88: LOOP 2drop 0 ;
89:
90: : Display ( n -- )
91: dup cells D-LineA + @ O-Buffer +
92: swap D-MaxLines @ + D-Lines @ min 1+
93: cells D-LineA + @ O-Buffer +
94: over - type ;
95:
96: \ [IFDEF] Green Colors on [THEN]
97: \ dup D-TableL + C@ dup Level ! dup XPos ! spaces 0 YPos !
98: \ D-LineIP + @ C-Stop off
99: \ BEGIN
100: \ [IFDEF] Green IP @ over =
101: \ IF hig# C-Highlight ! ELSE C-Highlight off THEN
102: \ [THEN]
103: \ Analyse
104: \ C-Stop @ YPos @ D-MaxLines @ u>= or
105: \ UNTIL drop ;
106:
107: : TopLine
108: 0 0 at-xy
109: Men# CT@ attr!
110: ." OSB-DEBUG (C) 1993 by Jens A. Wilke" cr cr
111: \ one step beyond
112: 0 CT@ attr! ;
113:
114: : BottomLine
115: 0 D-MaxLines @ 3 + at-xy
116: Men# CT@ attr!
117: ." U-nnest D-one N-est A-bort" cr
118: 0 CT@ attr! ;
119:
120: VARIABLE LastIP
121:
122: : (supress)
123: YPos @ D-MaxLines @ U>=
124: IF c-output off THEN ;
125:
126: : DispIP
127: ['] (supress) IS nlcount
128: dup SearchLine D-Line @ - dup YPos ! 2 +
129: over Body @ - 0 1 cells um/mod nip chars D-XPos + c@
130: swap AT-XY
131: Analyse drop
132: ['] noop IS nlcount
133: c-output on ;
134:
135: : Watcher ( -- )
136: TopLine
137: IP @ SearchLine dup D-Line @ dup D-MaxLines @ +
138: within
139: IF drop D-Line @ Display
140: ELSE D-MaxLines @ 2/ - 0 max dup D-Line !
141: Display
142: THEN
143: C-Formated off Colors on
144: \ LastIP @ ?DUP IF DispIP THEN
145: Hig# C-Highlight !
146: IP @ DispIP IP @ LastIP !
147: C-Formated on C-Highlight off
148: BottomLine ;
149:
150:
151: ' noop ALIAS \w immediate
152:
153: \ end formated debugger words
154:
155: [ELSE]
156: ' \ alias \w immediate
157:
158: : scanword ( body -- )
159: c-init C-Output off
160: ScanMode c-pass !
161: dup MakePass
162: 0 Level !
163: 0 XPos !
164: DisplayMode c-pass !
165: MakePass
166: C-Output on ;
167: [THEN]
168:
169: : .n 0 <# # # # # #S #> ctype bl cemit ;
170:
171: : d.s ." [ " depth . ." ] "
172: depth 4 min dup 0 ?DO dup i - pick .n LOOP drop ;
173:
174: : NoFine XPos off YPos off
175: NLFlag off Level off
176: C-Formated off
177: [IFDEF] Colors Colors off [THEN]
178: ;
179:
180: : disp-step
181: DisplayMode c-pass ! \ change to displaymode
182: \ Branches Off \ don't display
183: \ \ BEGIN and THEN
184: cr
185: \w YPos @ 1+ D-BugLine !
186: \w Watcher
187: c-stop off
188: \w 0 D-BugLine @ at-xy
189: Base @ hex IP @ 8 u.r space IP @ @ 8 u.r space
190: Base !
191: NoFine 10 XPos !
192: \w D-Bugline @ YPos !
193: ip @ DisplayMode c-pass ! Analyse drop
194: 25 XPos @ - 0 max spaces ." -> " ;
195:
196: : get-next ( -- n | n n )
197: DebugMode c-pass !
198: ip @ Analyse ;
199:
200: : jump ( addr -- )
201: r> drop \ discard last ip
202: >r ;
203:
204: AVARIABLE DebugLoop
205:
206: : breaker r> 1 cells - IP ! DebugLoop @ jump ;
207:
208: CREATE BP 0 , 0 ,
209: CREATE DT 0 , 0 ,
210:
211: : set-bp ( 0 n | 0 n n -- )
212: 0. BP 2!
213: ?dup IF dup BP ! dup @ DT !
214: ['] Breaker swap !
215: ?dup IF dup BP cell+ ! dup @ DT cell+ !
216: ['] Breaker swap ! drop THEN
217: THEN ;
218:
219: : restore-bp ( -- )
220: BP @ ?dup IF DT @ swap ! THEN
221: BP cell+ @ ?dup IF DT cell+ @ swap ! THEN ;
222:
223: VARIABLE Body
224:
225: : NestXT ( xt -- true | body false )
226: DebugMode c-pass ! C-Output off
1.5 ! anton 227: xt-see C-Output on
1.1 anton 228: c-pass @ DebugMode = dup
229: IF ." Cannot debug" cr
230: THEN ;
231:
232: VARIABLE Nesting
233:
234: : Leave-D
235: [IFDEF] Colors Colors on [THEN]
236: C-Formated on
237: C-Output on ;
238:
239: VARIABLE Unnest
240:
241: : D-KEY ( -- flag )
242: BEGIN
243: Unnest @ IF 0 ELSE key THEN
244: CASE [char] n OF IP @ @ NestXT EXIT ENDOF
245: [char] s OF Leave-D
246: -128 THROW ENDOF
247: [char] a OF Leave-D
248: -128 THROW ENDOF
249: [char] d OF Leave-D
250: cr ." Done..." cr
251: Nesting off
252: r> drop IP @ >r
253: EXIT ENDOF
254: [char] ? OF cr ." Nest Stop Done Unnest" cr
255: ENDOF
256: [char] u OF Unnest on true EXIT ENDOF
257: drop true EXIT
258: ENDCASE
259: AGAIN ;
260:
261: : (debug) ( body -- )
262: 0 Nesting !
263: BEGIN Unnest off
264: cr ." Scanning code..." cr C-Formated on
265: dup scanword IP !
266: cr ." Nesting debugger ready!" cr
267: \w WatcherInit 0 CT@ attr! page
268: BEGIN disp-step D-Key
269: WHILE C-Stop @ 0=
270: WHILE 0 get-next set-bp
271: IP @ jump
272: [ here DebugLoop ! ]
273: restore-bp
274: d.s
275: REPEAT
276: Nesting @ 0= ?EXIT
277: -1 Nesting +! r>
278: ELSE
279: IP @ >r 1 Nesting +!
280: THEN
281: AGAIN ;
282:
1.3 pazsan 283: : dbg ' NestXT ?EXIT (debug) Leave-D ;
1.1 anton 284:
1.2 pazsan 285: \ : test 1 2 4 swap dup . ;