projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Recognize Forth 2012 number syntax
[pforth] / fth / trace.fth
CommitLineData
8e9db35f
PB		 1\ @(#) trace.fth 98/01/28 1.2
2\ TRACE ( <name> -- , trace pForth word )
3\
4\ Single step debugger.
5\ TRACE ( i*x <name> -- , setup trace for Forth word )
6\ S ( -- , step over )
7\ SM ( many -- , step over many times )
8\ SD ( -- , step down )
9\ G ( -- , go to end of word )
10\ GD ( n -- , go down N levels from current level, stop at end of this level )
11\
12\ This debugger works by emulating the inner interpreter of pForth.
13\ It executes code and maintains a separate return stack for the
14\ program under test. Thus all primitives that operate on the return
15\ stack, such as DO and R> must be trapped. Local variables must
16\ also be handled specially. Several state variables are also
17\ saved and restored to establish the context for the program being
18\ tested.
19\
20\ Copyright 1997 Phil Burk
21\
22\ Modifications:
23\ 19990930 John Providenza - Fixed stack bugs in GD
24
25anew task-trace.fth
26
27: SPACE.TO.COLUMN ( col -- )
28 out @ - spaces
29;
30
31: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
32 ['] first_colon <
33;
34
350 value TRACE_IP \ instruction pointer
360 value TRACE_LEVEL \ level of descent for inner interpreter
370 value TRACE_LEVEL_MAX \ maximum level of descent
38
39private{
40
41\ use fake return stack
42128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
43create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
44variable TRACE-RSP
45: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
46: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
47: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
48: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
49: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
50: TRACE.RDROP ( -- ) cell trace-rsp +! ;
51: TRACE.RCHECK ( -- , abort if return stack out of range )
52 trace-rsp @ trace-return-stack u<
53 abort" TRACE return stack OVERFLOW!"
54 trace-rsp @ trace-return-stack trace_return_size + 12 + u>
55 abort" TRACE return stack UNDERFLOW!"
56;
57
58\ save and restore several state variables
5910 cells constant TRACE_STATE_SIZE
60create TRACE-STATE-1 TRACE_STATE_SIZE allot
61create TRACE-STATE-2 TRACE_STATE_SIZE allot
62
63variable TRACE-STATE-PTR
64: TRACE.SAVE++ ( addr -- , save next thing )
65 @ trace-state-ptr @ !
66 cell trace-state-ptr +!
67;
68
69: TRACE.SAVE.STATE ( -- )
70 state trace.save++
71 hld trace.save++
72 base trace.save++
73;
74
75: TRACE.SAVE.STATE1 ( -- , save normal state )
76 trace-state-1 trace-state-ptr !
77 trace.save.state
78;
79: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
80 trace-state-2 trace-state-ptr !
81 trace.save.state
82;
83
84
85: TRACE.RESTORE++ ( addr -- , restore next thing )
86 trace-state-ptr @ @ swap !
87 cell trace-state-ptr +!
88;
89
90: TRACE.RESTORE.STATE ( -- )
91 state trace.restore++
92 hld trace.restore++
93 base trace.restore++
94;
95
96: TRACE.RESTORE.STATE1 ( -- )
97 trace-state-1 trace-state-ptr !
98 trace.restore.state
99;
100: TRACE.RESTORE.STATE2 ( -- )
101 trace-state-2 trace-state-ptr !
102 trace.restore.state
103;
104
105\ The implementation of these pForth primitives is specific to pForth.
106
107variable TRACE-LOCALS-PTR \ point to top of local frame
108
109\ create a return stack frame for NUM local variables
110: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
111 trace-locals-ptr @ trace.>r
112 trace-rsp @ trace-locals-ptr !
113 trace-rsp @ num cells - trace-rsp ! \ make room for locals
114 trace-rsp @ -> lp
115 num 0
116 DO
117 lp !
118 cell +-> lp \ move data into locals frame on return stack
119 LOOP
120;
121
122: TRACE.(LOCAL.EXIT) ( -- )
123 trace-locals-ptr @ trace-rsp !
124 trace.r> trace-locals-ptr !
125;
126: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
127 trace-locals-ptr @ swap cells - @
128;
129: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
130: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
131: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
132: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
133: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
134: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
135: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
136: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
137
138: TRACE.(LOCAL!) ( n l# -- , store into local frame )
139 trace-locals-ptr @ swap cells - !
140;
141: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
142: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
143: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
144: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
145: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
146: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
147: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
148: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
149
150: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
151 trace-locals-ptr @ swap cells - +!
152;
153: TRACE.(?DO) { limit start ip -- ip' }
154 limit start =
155 IF
156 ip @ +-> ip \ BRANCH
157 ELSE
158 start trace.>r
159 limit trace.>r
160 cell +-> ip
161 THEN
162 ip
163;
164
165: TRACE.(LOOP) { ip | limit indx -- ip' }
166 trace.r> -> limit
167 trace.r> 1+ -> indx
168 limit indx =
169 IF
170 cell +-> ip
171 ELSE
172 indx trace.>r
173 limit trace.>r
174 ip @ +-> ip
175 THEN
176 ip
177;
178
179: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
180 trace.r> -> limit
181 trace.r> -> oldindx
182 oldindx delta + -> indx
183\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
184\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
185\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
186 oldindx limit - limit 1- indx - AND $ 80000000 AND
187 indx limit - limit 1- oldindx - AND $ 80000000 AND OR
188 IF
189 cell +-> ip
190 ELSE
191 indx trace.>r
192 limit trace.>r
193 ip @ +-> ip
194 THEN
195 ip
196;
197
198: TRACE.CHECK.IP { ip -- }
199 ip ['] first_colon u<
200 ip here u> OR
201 IF
202 ." TRACE - IP out of range = " ip .hex cr
203 abort
204 THEN
205;
206
207: TRACE.SHOW.IP { ip -- , print name and offset }
208 ip code> >name dup id.
209 name> >code ip swap - ." +" .
210;
211
212: TRACE.SHOW.STACK { | mdepth -- }
213 base @ >r
214 ." <" base @ decimal 1 .r ." :"
215 depth 1 .r ." > "
216 r> base !
217 depth 5 min -> mdepth
218 depth mdepth -
219 IF
220 ." ... " \ if we don't show entire stack
221 THEN
222 mdepth 0
223 ?DO
224 mdepth i 1+ - pick . \ show numbers in current base
225 LOOP
226;
227
228: TRACE.SHOW.NEXT { ip -- }
229 >newline
230 ip trace.check.ip
231\ show word name and offset
232 ." << "
233 ip trace.show.ip
234 16 space.to.column
235\ show data stack
236 trace.show.stack
237 40 space.to.column ." ||"
238 trace_level 2* spaces
239 ip code@
240 cell +-> ip
241\ show primitive about to be executed
242 dup .xt space
243\ trap any primitives that are followed by inline data
244 CASE
245 ['] (LITERAL) OF ip @ . ENDOF
246 ['] (ALITERAL) OF ip a@ . ENDOF
247[ exists? (FLITERAL) [IF] ]
248 ['] (FLITERAL) OF ip f@ f. ENDOF
249[ [THEN] ]
250 ['] BRANCH OF ip @ . ENDOF
251 ['] 0BRANCH OF ip @ . ENDOF
252 ['] (.") OF ip count type .' "' ENDOF
253 ['] (C") OF ip count type .' "' ENDOF
254 ['] (S") OF ip count type .' "' ENDOF
255 ENDCASE
256 65 space.to.column ." >> "
257;
258
259: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
260 xt
261 CASE
262 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
263 ['] (CREATE) OF ip cell- body_offset + ENDOF
264 ['] (LITERAL) OF ip @ cell +-> ip ENDOF
265 ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
266[ exists? (FLITERAL) [IF] ]
267 ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
268[ [THEN] ]
269 ['] BRANCH OF ip @ +-> ip ENDOF
270 ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
271 ['] >R OF trace.>r ENDOF
272 ['] R> OF trace.r> ENDOF
273 ['] R@ OF trace.r@ ENDOF
274 ['] RDROP OF trace.rdrop ENDOF
275 ['] 2>R OF trace.>r trace.>r ENDOF
276 ['] 2R> OF trace.r> trace.r> ENDOF
277 ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
278 ['] i OF 1 trace.rpick ENDOF
279 ['] j OF 3 trace.rpick ENDOF
280 ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
281 ['] (LOOP) OF ip trace.(loop) -> ip ENDOF
282 ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
283 ['] (DO) OF trace.>r trace.>r ENDOF
284 ['] (?DO) OF ip trace.(?do) -> ip ENDOF
285 ['] (.") OF ip count type ip count + aligned -> ip ENDOF
286 ['] (C") OF ip ip count + aligned -> ip ENDOF
287 ['] (S") OF ip count ip count + aligned -> ip ENDOF
288 ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
289 ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
290 ['] (LOCAL@) OF trace.(local@) ENDOF
291 ['] (1_LOCAL@) OF trace.(1_local@) ENDOF
292 ['] (2_LOCAL@) OF trace.(2_local@) ENDOF
293 ['] (3_LOCAL@) OF trace.(3_local@) ENDOF
294 ['] (4_LOCAL@) OF trace.(4_local@) ENDOF
295 ['] (5_LOCAL@) OF trace.(5_local@) ENDOF
296 ['] (6_LOCAL@) OF trace.(6_local@) ENDOF
297 ['] (7_LOCAL@) OF trace.(7_local@) ENDOF
298 ['] (8_LOCAL@) OF trace.(8_local@) ENDOF
299 ['] (LOCAL!) OF trace.(local!) ENDOF
300 ['] (1_LOCAL!) OF trace.(1_local!) ENDOF
301 ['] (2_LOCAL!) OF trace.(2_local!) ENDOF
302 ['] (3_LOCAL!) OF trace.(3_local!) ENDOF
303 ['] (4_LOCAL!) OF trace.(4_local!) ENDOF
304 ['] (5_LOCAL!) OF trace.(5_local!) ENDOF
305 ['] (6_LOCAL!) OF trace.(6_local!) ENDOF
306 ['] (7_LOCAL!) OF trace.(7_local!) ENDOF
307 ['] (8_LOCAL!) OF trace.(8_local!) ENDOF
308 ['] (LOCAL+!) OF trace.(local+!) ENDOF
309 >r xt EXECUTE r>
310 ENDCASE
311 ip
312;
313
314: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
315 ip trace.check.ip
316\ set context for word under test
317 trace.save.state1
318 here -> oldhere
319 trace.restore.state2
320 oldhere 256 + dp !
321\ get execution token
322 ip code@ -> xt
323 cell +-> ip
324\ execute token
325 xt is.primitive?
326 IF \ primitive
327 ip xt trace.do.primitive -> ip
328 ELSE \ secondary
329 trace_level trace_level_max <
330 IF
331 ip trace.>r \ threaded execution
332 1 +-> trace_level
333 xt codebase + -> ip
334 ELSE
335 \ treat it as a primitive
336 ip xt trace.do.primitive -> ip
337 THEN
338 THEN
339\ restore original context
340 trace.rcheck
341 trace.save.state2
342 trace.restore.state1
343 oldhere dp !
344 ip
345;
346
347: TRACE.NEXT { ip | xt -- ip' }
348 trace_level 0>
349 IF
350 ip trace.do.next -> ip
351 THEN
352 trace_level 0>
353 IF
354 ip trace.show.next
355 ELSE
356 trace-stack on
357 ." Finished." cr
358 THEN
359 ip
360;
361
362}private
363
364: TRACE ( i*x <name> -- i*x , setup trace environment )
365 ' dup is.primitive?
366 IF
367 drop ." Sorry. You can't trace a primitive." cr
368 ELSE
369 1 -> trace_level
370 trace_level -> trace_level_max
371 trace.0rp
372 >code -> trace_ip
373 trace_ip trace.show.next
374 trace-stack off
375 trace.save.state2
376 THEN
377;
378
379: s ( -- , step over )
380 trace_level -> trace_level_max
381 trace_ip trace.next -> trace_ip
382;
383
384: sd ( -- , step down )
385 trace_level 1+ -> trace_level_max
386 trace_ip trace.next -> trace_ip
387;
388
389: sm ( many -- , step many times )
390 trace_level -> trace_level_max
391 0
392 ?DO
393 trace_ip trace.next -> trace_ip
394 LOOP
395;
396
397defer trace.user ( IP -- stop? )
398' 0= is trace.user
399
400: gd { more_levels | stop_level -- }
401 here what's trace.user u< \ has it been forgotten?
402 IF
403 ." Resetting TRACE.USER !!!" cr
404 ['] 0= is trace.user
405 THEN
406
407 more_levels 0<
408 more_levels 10 >
409 or \ 19990930 - OR was missing
410 IF
411 ." GD level out of range (0-10), = " more_levels . cr
412 ELSE
413 trace_level more_levels + -> trace_level_max
414 trace_level 1- -> stop_level
415 BEGIN
416 trace_ip trace.user \ call deferred user word
417 ?dup \ leave flag for UNTIL \ 19990930 - was DUP
418 IF
419 ." TRACE.USER returned " dup . ." so stopping execution." cr
420 ELSE
421 trace_ip trace.next -> trace_ip
422 trace_level stop_level > not
423 THEN
424 UNTIL
425 THEN
426;
427
428: g ( -- , execute until end of word )
429 0 gd
430;
431
432: TRACE.HELP ( -- )
433 ." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
434 ." S ( -- , step over )" cr
435 ." SM ( many -- , step over many times )" cr
436 ." SD ( -- , step down )" cr
437 ." G ( -- , go to end of word )" cr
438 ." GD ( n -- , go down N levels from current level," cr
439 ." stop at end of this level )" cr
440;
441
442privatize
443
4440 [IF]
445variable var1
446100 var1 !
447: FOO dup IF 1 + . THEN 77 var1 @ + . ;
448: ZOO 29 foo 99 22 + . ;
449: ROO 92 >r 1 r@ + . r> . ;
450: MOO c" hello" count type
451 ." This is a message." cr
452 s" another message" type cr
453;
454: KOO 7 FOO ." DONE" ;
455: TR.DO 4 0 DO i . LOOP ;
456: TR.?DO 0 ?DO i . LOOP ;
457: TR.LOC1 { aa bb } aa bb + . ;
458: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
459
460[THEN]
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.