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