-\ @(#) trace.fth 98/01/28 1.2\r
-\ TRACE ( <name> -- , trace pForth word )\r
-\\r
-\ Single step debugger.\r
-\ TRACE ( i*x <name> -- , setup trace for Forth word )\r
-\ S ( -- , step over )\r
-\ SM ( many -- , step over many times )\r
-\ SD ( -- , step down )\r
-\ G ( -- , go to end of word )\r
-\ GD ( n -- , go down N levels from current level, stop at end of this level )\r
-\\r
-\ This debugger works by emulating the inner interpreter of pForth.\r
-\ It executes code and maintains a separate return stack for the\r
-\ program under test. Thus all primitives that operate on the return\r
-\ stack, such as DO and R> must be trapped. Local variables must\r
-\ also be handled specially. Several state variables are also\r
-\ saved and restored to establish the context for the program being\r
-\ tested.\r
-\ \r
-\ Copyright 1997 Phil Burk\r
-\\r
-\ Modifications:\r
-\ 19990930 John Providenza - Fixed stack bugs in GD\r
-\r
-anew task-trace.fth\r
-\r
-: SPACE.TO.COLUMN ( col -- )\r
- out @ - spaces\r
-;\r
-\r
-: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )\r
- ['] first_colon <\r
-;\r
-\r
-0 value TRACE_IP \ instruction pointer\r
-0 value TRACE_LEVEL \ level of descent for inner interpreter\r
-0 value TRACE_LEVEL_MAX \ maximum level of descent\r
-\r
-private{\r
-\r
-\ use fake return stack\r
-128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes\r
-create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot\r
-variable TRACE-RSP\r
-: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n\r
-: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++\r
-: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp\r
-: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]\r
-: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;\r
-: TRACE.RDROP ( -- ) cell trace-rsp +! ;\r
-: TRACE.RCHECK ( -- , abort if return stack out of range )\r
- trace-rsp @ trace-return-stack u<\r
- abort" TRACE return stack OVERFLOW!"\r
- trace-rsp @ trace-return-stack trace_return_size + 12 + u>\r
- abort" TRACE return stack UNDERFLOW!"\r
-;\r
-\r
-\ save and restore several state variables\r
-10 cells constant TRACE_STATE_SIZE\r
-create TRACE-STATE-1 TRACE_STATE_SIZE allot\r
-create TRACE-STATE-2 TRACE_STATE_SIZE allot\r
-\r
-variable TRACE-STATE-PTR\r
-: TRACE.SAVE++ ( addr -- , save next thing )\r
- @ trace-state-ptr @ !\r
- cell trace-state-ptr +!\r
-;\r
-\r
-: TRACE.SAVE.STATE ( -- )\r
- state trace.save++\r
- hld trace.save++\r
- base trace.save++\r
-;\r
-\r
-: TRACE.SAVE.STATE1 ( -- , save normal state )\r
- trace-state-1 trace-state-ptr !\r
- trace.save.state\r
-;\r
-: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )\r
- trace-state-2 trace-state-ptr !\r
- trace.save.state\r
-;\r
-\r
-\r
-: TRACE.RESTORE++ ( addr -- , restore next thing )\r
- trace-state-ptr @ @ swap !\r
- cell trace-state-ptr +!\r
-;\r
-\r
-: TRACE.RESTORE.STATE ( -- )\r
- state trace.restore++\r
- hld trace.restore++\r
- base trace.restore++\r
-;\r
-\r
-: TRACE.RESTORE.STATE1 ( -- )\r
- trace-state-1 trace-state-ptr !\r
- trace.restore.state\r
-;\r
-: TRACE.RESTORE.STATE2 ( -- )\r
- trace-state-2 trace-state-ptr !\r
- trace.restore.state\r
-;\r
-\r
-\ The implementation of these pForth primitives is specific to pForth.\r
-\r
-variable TRACE-LOCALS-PTR \ point to top of local frame\r
-\r
-\ create a return stack frame for NUM local variables\r
-: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }\r
- trace-locals-ptr @ trace.>r\r
- trace-rsp @ trace-locals-ptr !\r
- trace-rsp @ num cells - trace-rsp ! \ make room for locals\r
- trace-rsp @ -> lp\r
- num 0\r
- DO\r
- lp !\r
- cell +-> lp \ move data into locals frame on return stack\r
- LOOP\r
-;\r
- \r
-: TRACE.(LOCAL.EXIT) ( -- )\r
- trace-locals-ptr @ trace-rsp !\r
- trace.r> trace-locals-ptr !\r
-;\r
-: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )\r
- trace-locals-ptr @ swap cells - @\r
-;\r
-: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;\r
-: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;\r
-: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;\r
-: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;\r
-: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;\r
-: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;\r
-: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;\r
-: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;\r
-\r
-: TRACE.(LOCAL!) ( n l# -- , store into local frame )\r
- trace-locals-ptr @ swap cells - !\r
-;\r
-: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;\r
-: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;\r
-: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;\r
-: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;\r
-: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;\r
-: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;\r
-: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;\r
-: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;\r
-\r
-: TRACE.(LOCAL+!) ( n l# -- , store into local frame )\r
- trace-locals-ptr @ swap cells - +!\r
-;\r
-: TRACE.(?DO) { limit start ip -- ip' }\r
- limit start =\r
- IF\r
- ip @ +-> ip \ BRANCH\r
- ELSE\r
- start trace.>r\r
- limit trace.>r\r
- cell +-> ip\r
- THEN\r
- ip\r
-;\r
-\r
-: TRACE.(LOOP) { ip | limit indx -- ip' }\r
- trace.r> -> limit\r
- trace.r> 1+ -> indx\r
- limit indx =\r
- IF\r
- cell +-> ip\r
- ELSE\r
- indx trace.>r\r
- limit trace.>r\r
- ip @ +-> ip\r
- THEN\r
- ip\r
-;\r
-\r
-: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }\r
- trace.r> -> limit\r
- trace.r> -> oldindx\r
- oldindx delta + -> indx\r
-\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */\r
-\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||\r
-\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )\r
- oldindx limit - limit 1- indx - AND $ 80000000 AND\r
- indx limit - limit 1- oldindx - AND $ 80000000 AND OR\r
- IF\r
- cell +-> ip\r
- ELSE\r
- indx trace.>r\r
- limit trace.>r\r
- ip @ +-> ip\r
- THEN\r
- ip\r
-;\r
-\r
-: TRACE.CHECK.IP { ip -- }\r
- ip ['] first_colon u<\r
- ip here u> OR\r
- IF\r
- ." TRACE - IP out of range = " ip .hex cr\r
- abort\r
- THEN\r
-;\r
-\r
-: TRACE.SHOW.IP { ip -- , print name and offset }\r
- ip code> >name dup id.\r
- name> >code ip swap - ." +" .\r
-;\r
-\r
-: TRACE.SHOW.STACK { | mdepth -- }\r
- base @ >r\r
- ." <" base @ decimal 1 .r ." :"\r
- depth 1 .r ." > "\r
- r> base !\r
- depth 5 min -> mdepth\r
- depth mdepth -\r
- IF\r
- ." ... " \ if we don't show entire stack\r
- THEN\r
- mdepth 0\r
- ?DO\r
- mdepth i 1+ - pick . \ show numbers in current base\r
- LOOP\r
-;\r
-\r
-: TRACE.SHOW.NEXT { ip -- }\r
- >newline\r
- ip trace.check.ip\r
-\ show word name and offset\r
- ." << "\r
- ip trace.show.ip\r
- 16 space.to.column\r
-\ show data stack\r
- trace.show.stack\r
- 40 space.to.column ." ||"\r
- trace_level 2* spaces\r
- ip code@\r
- cell +-> ip\r
-\ show primitive about to be executed\r
- dup .xt space\r
-\ trap any primitives that are followed by inline data\r
- CASE\r
- ['] (LITERAL) OF ip @ . ENDOF\r
- ['] (ALITERAL) OF ip a@ . ENDOF\r
-[ exists? (FLITERAL) [IF] ]\r
- ['] (FLITERAL) OF ip f@ f. ENDOF\r
-[ [THEN] ]\r
- ['] BRANCH OF ip @ . ENDOF\r
- ['] 0BRANCH OF ip @ . ENDOF\r
- ['] (.") OF ip count type .' "' ENDOF\r
- ['] (C") OF ip count type .' "' ENDOF\r
- ['] (S") OF ip count type .' "' ENDOF\r
- ENDCASE\r
- 65 space.to.column ." >> "\r
-;\r
-\r
-: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }\r
- xt\r
- CASE\r
- 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT\r
- ['] (CREATE) OF ip cell- body_offset + ENDOF\r
- ['] (LITERAL) OF ip @ cell +-> ip ENDOF\r
- ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF\r
-[ exists? (FLITERAL) [IF] ]\r
- ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF\r
-[ [THEN] ]\r
- ['] BRANCH OF ip @ +-> ip ENDOF\r
- ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF\r
- ['] >R OF trace.>r ENDOF\r
- ['] R> OF trace.r> ENDOF\r
- ['] R@ OF trace.r@ ENDOF\r
- ['] RDROP OF trace.rdrop ENDOF\r
- ['] 2>R OF trace.>r trace.>r ENDOF\r
- ['] 2R> OF trace.r> trace.r> ENDOF\r
- ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF\r
- ['] i OF 1 trace.rpick ENDOF\r
- ['] j OF 3 trace.rpick ENDOF\r
- ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF\r
- ['] (LOOP) OF ip trace.(loop) -> ip ENDOF\r
- ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF\r
- ['] (DO) OF trace.>r trace.>r ENDOF\r
- ['] (?DO) OF ip trace.(?do) -> ip ENDOF\r
- ['] (.") OF ip count type ip count + aligned -> ip ENDOF\r
- ['] (C") OF ip ip count + aligned -> ip ENDOF\r
- ['] (S") OF ip count ip count + aligned -> ip ENDOF\r
- ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF\r
- ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF\r
- ['] (LOCAL@) OF trace.(local@) ENDOF\r
- ['] (1_LOCAL@) OF trace.(1_local@) ENDOF\r
- ['] (2_LOCAL@) OF trace.(2_local@) ENDOF\r
- ['] (3_LOCAL@) OF trace.(3_local@) ENDOF\r
- ['] (4_LOCAL@) OF trace.(4_local@) ENDOF\r
- ['] (5_LOCAL@) OF trace.(5_local@) ENDOF\r
- ['] (6_LOCAL@) OF trace.(6_local@) ENDOF\r
- ['] (7_LOCAL@) OF trace.(7_local@) ENDOF\r
- ['] (8_LOCAL@) OF trace.(8_local@) ENDOF\r
- ['] (LOCAL!) OF trace.(local!) ENDOF\r
- ['] (1_LOCAL!) OF trace.(1_local!) ENDOF\r
- ['] (2_LOCAL!) OF trace.(2_local!) ENDOF\r
- ['] (3_LOCAL!) OF trace.(3_local!) ENDOF\r
- ['] (4_LOCAL!) OF trace.(4_local!) ENDOF\r
- ['] (5_LOCAL!) OF trace.(5_local!) ENDOF\r
- ['] (6_LOCAL!) OF trace.(6_local!) ENDOF\r
- ['] (7_LOCAL!) OF trace.(7_local!) ENDOF\r
- ['] (8_LOCAL!) OF trace.(8_local!) ENDOF\r
- ['] (LOCAL+!) OF trace.(local+!) ENDOF\r
- >r xt EXECUTE r>\r
- ENDCASE\r
- ip\r
-;\r
-\r
-: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }\r
- ip trace.check.ip\r
-\ set context for word under test\r
- trace.save.state1\r
- here -> oldhere\r
- trace.restore.state2\r
- oldhere 256 + dp !\r
-\ get execution token\r
- ip code@ -> xt\r
- cell +-> ip\r
-\ execute token\r
- xt is.primitive?\r
- IF \ primitive\r
- ip xt trace.do.primitive -> ip\r
- ELSE \ secondary\r
- trace_level trace_level_max <\r
- IF\r
- ip trace.>r \ threaded execution\r
- 1 +-> trace_level\r
- xt codebase + -> ip\r
- ELSE\r
- \ treat it as a primitive\r
- ip xt trace.do.primitive -> ip\r
- THEN \r
- THEN\r
-\ restore original context\r
- trace.rcheck\r
- trace.save.state2\r
- trace.restore.state1\r
- oldhere dp !\r
- ip\r
-;\r
-\r
-: TRACE.NEXT { ip | xt -- ip' }\r
- trace_level 0>\r
- IF\r
- ip trace.do.next -> ip\r
- THEN\r
- trace_level 0>\r
- IF\r
- ip trace.show.next\r
- ELSE\r
- trace-stack on\r
- ." Finished." cr\r
- THEN\r
- ip\r
-;\r
-\r
-}private\r
-\r
-: TRACE ( i*x <name> -- i*x , setup trace environment )\r
- ' dup is.primitive?\r
- IF\r
- drop ." Sorry. You can't trace a primitive." cr\r
- ELSE\r
- 1 -> trace_level\r
- trace_level -> trace_level_max\r
- trace.0rp\r
- >code -> trace_ip\r
- trace_ip trace.show.next\r
- trace-stack off\r
- trace.save.state2\r
- THEN\r
-;\r
-\r
-: s ( -- , step over )\r
- trace_level -> trace_level_max\r
- trace_ip trace.next -> trace_ip\r
-;\r
-\r
-: sd ( -- , step down )\r
- trace_level 1+ -> trace_level_max\r
- trace_ip trace.next -> trace_ip\r
-;\r
-\r
-: sm ( many -- , step many times )\r
- trace_level -> trace_level_max\r
- 0\r
- ?DO\r
- trace_ip trace.next -> trace_ip\r
- LOOP\r
-;\r
-\r
-defer trace.user ( IP -- stop? )\r
-' 0= is trace.user\r
-\r
-: gd { more_levels | stop_level -- }\r
- here what's trace.user u< \ has it been forgotten?\r
- IF\r
- ." Resetting TRACE.USER !!!" cr\r
- ['] 0= is trace.user\r
- THEN\r
-\r
- more_levels 0<\r
- more_levels 10 >\r
- or \ 19990930 - OR was missing\r
- IF\r
- ." GD level out of range (0-10), = " more_levels . cr\r
- ELSE\r
- trace_level more_levels + -> trace_level_max\r
- trace_level 1- -> stop_level\r
- BEGIN\r
- trace_ip trace.user \ call deferred user word\r
- ?dup \ leave flag for UNTIL \ 19990930 - was DUP\r
- IF\r
- ." TRACE.USER returned " dup . ." so stopping execution." cr\r
- ELSE\r
- trace_ip trace.next -> trace_ip\r
- trace_level stop_level > not\r
- THEN\r
- UNTIL\r
- THEN\r
-;\r
-\r
-: g ( -- , execute until end of word )\r
- 0 gd\r
-;\r
-\r
-: TRACE.HELP ( -- )\r
- ." TRACE ( i*x <name> -- , setup trace for Forth word )" cr\r
- ." S ( -- , step over )" cr\r
- ." SM ( many -- , step over many times )" cr\r
- ." SD ( -- , step down )" cr\r
- ." G ( -- , go to end of word )" cr\r
- ." GD ( n -- , go down N levels from current level," cr\r
- ." stop at end of this level )" cr\r
-;\r
-\r
-privatize\r
-\r
-0 [IF]\r
-variable var1\r
-100 var1 !\r
-: FOO dup IF 1 + . THEN 77 var1 @ + . ;\r
-: ZOO 29 foo 99 22 + . ;\r
-: ROO 92 >r 1 r@ + . r> . ;\r
-: MOO c" hello" count type\r
- ." This is a message." cr\r
- s" another message" type cr\r
-;\r
-: KOO 7 FOO ." DONE" ;\r
-: TR.DO 4 0 DO i . LOOP ;\r
-: TR.?DO 0 ?DO i . LOOP ;\r
-: TR.LOC1 { aa bb } aa bb + . ;\r
-: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;\r
- \r
-[THEN]\r
+\ @(#) trace.fth 98/01/28 1.2
+\ TRACE ( <name> -- , trace pForth word )
+\
+\ Single step debugger.
+\ TRACE ( i*x <name> -- , setup trace for Forth word )
+\ S ( -- , step over )
+\ SM ( many -- , step over many times )
+\ SD ( -- , step down )
+\ G ( -- , go to end of word )
+\ GD ( n -- , go down N levels from current level, stop at end of this level )
+\
+\ This debugger works by emulating the inner interpreter of pForth.
+\ It executes code and maintains a separate return stack for the
+\ program under test. Thus all primitives that operate on the return
+\ stack, such as DO and R> must be trapped. Local variables must
+\ also be handled specially. Several state variables are also
+\ saved and restored to establish the context for the program being
+\ tested.
+\
+\ Copyright 1997 Phil Burk
+\
+\ Modifications:
+\ 19990930 John Providenza - Fixed stack bugs in GD
+
+anew task-trace.fth
+
+: SPACE.TO.COLUMN ( col -- )
+ out @ - spaces
+;
+
+: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
+ ['] first_colon <
+;
+
+0 value TRACE_IP \ instruction pointer
+0 value TRACE_LEVEL \ level of descent for inner interpreter
+0 value TRACE_LEVEL_MAX \ maximum level of descent
+
+private{
+
+\ use fake return stack
+128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
+create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
+variable TRACE-RSP
+: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
+: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
+: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
+: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
+: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
+: TRACE.RDROP ( -- ) cell trace-rsp +! ;
+: TRACE.RCHECK ( -- , abort if return stack out of range )
+ trace-rsp @ trace-return-stack u<
+ abort" TRACE return stack OVERFLOW!"
+ trace-rsp @ trace-return-stack trace_return_size + 12 + u>
+ abort" TRACE return stack UNDERFLOW!"
+;
+
+\ save and restore several state variables
+10 cells constant TRACE_STATE_SIZE
+create TRACE-STATE-1 TRACE_STATE_SIZE allot
+create TRACE-STATE-2 TRACE_STATE_SIZE allot
+
+variable TRACE-STATE-PTR
+: TRACE.SAVE++ ( addr -- , save next thing )
+ @ trace-state-ptr @ !
+ cell trace-state-ptr +!
+;
+
+: TRACE.SAVE.STATE ( -- )
+ state trace.save++
+ hld trace.save++
+ base trace.save++
+;
+
+: TRACE.SAVE.STATE1 ( -- , save normal state )
+ trace-state-1 trace-state-ptr !
+ trace.save.state
+;
+: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
+ trace-state-2 trace-state-ptr !
+ trace.save.state
+;
+
+
+: TRACE.RESTORE++ ( addr -- , restore next thing )
+ trace-state-ptr @ @ swap !
+ cell trace-state-ptr +!
+;
+
+: TRACE.RESTORE.STATE ( -- )
+ state trace.restore++
+ hld trace.restore++
+ base trace.restore++
+;
+
+: TRACE.RESTORE.STATE1 ( -- )
+ trace-state-1 trace-state-ptr !
+ trace.restore.state
+;
+: TRACE.RESTORE.STATE2 ( -- )
+ trace-state-2 trace-state-ptr !
+ trace.restore.state
+;
+
+\ The implementation of these pForth primitives is specific to pForth.
+
+variable TRACE-LOCALS-PTR \ point to top of local frame
+
+\ create a return stack frame for NUM local variables
+: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
+ trace-locals-ptr @ trace.>r
+ trace-rsp @ trace-locals-ptr !
+ trace-rsp @ num cells - trace-rsp ! \ make room for locals
+ trace-rsp @ -> lp
+ num 0
+ DO
+ lp !
+ cell +-> lp \ move data into locals frame on return stack
+ LOOP
+;
+
+: TRACE.(LOCAL.EXIT) ( -- )
+ trace-locals-ptr @ trace-rsp !
+ trace.r> trace-locals-ptr !
+;
+: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
+ trace-locals-ptr @ swap cells - @
+;
+: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
+: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
+: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
+: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
+: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
+: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
+: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
+: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
+
+: TRACE.(LOCAL!) ( n l# -- , store into local frame )
+ trace-locals-ptr @ swap cells - !
+;
+: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
+: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
+: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
+: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
+: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
+: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
+: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
+: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
+
+: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
+ trace-locals-ptr @ swap cells - +!
+;
+: TRACE.(?DO) { limit start ip -- ip' }
+ limit start =
+ IF
+ ip @ +-> ip \ BRANCH
+ ELSE
+ start trace.>r
+ limit trace.>r
+ cell +-> ip
+ THEN
+ ip
+;
+
+: TRACE.(LOOP) { ip | limit indx -- ip' }
+ trace.r> -> limit
+ trace.r> 1+ -> indx
+ limit indx =
+ IF
+ cell +-> ip
+ ELSE
+ indx trace.>r
+ limit trace.>r
+ ip @ +-> ip
+ THEN
+ ip
+;
+
+: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
+ trace.r> -> limit
+ trace.r> -> oldindx
+ oldindx delta + -> indx
+\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
+\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
+\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
+ oldindx limit - limit 1- indx - AND $ 80000000 AND
+ indx limit - limit 1- oldindx - AND $ 80000000 AND OR
+ IF
+ cell +-> ip
+ ELSE
+ indx trace.>r
+ limit trace.>r
+ ip @ +-> ip
+ THEN
+ ip
+;
+
+: TRACE.CHECK.IP { ip -- }
+ ip ['] first_colon u<
+ ip here u> OR
+ IF
+ ." TRACE - IP out of range = " ip .hex cr
+ abort
+ THEN
+;
+
+: TRACE.SHOW.IP { ip -- , print name and offset }
+ ip code> >name dup id.
+ name> >code ip swap - ." +" .
+;
+
+: TRACE.SHOW.STACK { | mdepth -- }
+ base @ >r
+ ." <" base @ decimal 1 .r ." :"
+ depth 1 .r ." > "
+ r> base !
+ depth 5 min -> mdepth
+ depth mdepth -
+ IF
+ ." ... " \ if we don't show entire stack
+ THEN
+ mdepth 0
+ ?DO
+ mdepth i 1+ - pick . \ show numbers in current base
+ LOOP
+;
+
+: TRACE.SHOW.NEXT { ip -- }
+ >newline
+ ip trace.check.ip
+\ show word name and offset
+ ." << "
+ ip trace.show.ip
+ 16 space.to.column
+\ show data stack
+ trace.show.stack
+ 40 space.to.column ." ||"
+ trace_level 2* spaces
+ ip code@
+ cell +-> ip
+\ show primitive about to be executed
+ dup .xt space
+\ trap any primitives that are followed by inline data
+ CASE
+ ['] (LITERAL) OF ip @ . ENDOF
+ ['] (ALITERAL) OF ip a@ . ENDOF
+[ exists? (FLITERAL) [IF] ]
+ ['] (FLITERAL) OF ip f@ f. ENDOF
+[ [THEN] ]
+ ['] BRANCH OF ip @ . ENDOF
+ ['] 0BRANCH OF ip @ . ENDOF
+ ['] (.") OF ip count type .' "' ENDOF
+ ['] (C") OF ip count type .' "' ENDOF
+ ['] (S") OF ip count type .' "' ENDOF
+ ENDCASE
+ 65 space.to.column ." >> "
+;
+
+: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
+ xt
+ CASE
+ 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
+ ['] (CREATE) OF ip cell- body_offset + ENDOF
+ ['] (LITERAL) OF ip @ cell +-> ip ENDOF
+ ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
+[ exists? (FLITERAL) [IF] ]
+ ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
+[ [THEN] ]
+ ['] BRANCH OF ip @ +-> ip ENDOF
+ ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
+ ['] >R OF trace.>r ENDOF
+ ['] R> OF trace.r> ENDOF
+ ['] R@ OF trace.r@ ENDOF
+ ['] RDROP OF trace.rdrop ENDOF
+ ['] 2>R OF trace.>r trace.>r ENDOF
+ ['] 2R> OF trace.r> trace.r> ENDOF
+ ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
+ ['] i OF 1 trace.rpick ENDOF
+ ['] j OF 3 trace.rpick ENDOF
+ ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
+ ['] (LOOP) OF ip trace.(loop) -> ip ENDOF
+ ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
+ ['] (DO) OF trace.>r trace.>r ENDOF
+ ['] (?DO) OF ip trace.(?do) -> ip ENDOF
+ ['] (.") OF ip count type ip count + aligned -> ip ENDOF
+ ['] (C") OF ip ip count + aligned -> ip ENDOF
+ ['] (S") OF ip count ip count + aligned -> ip ENDOF
+ ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
+ ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
+ ['] (LOCAL@) OF trace.(local@) ENDOF
+ ['] (1_LOCAL@) OF trace.(1_local@) ENDOF
+ ['] (2_LOCAL@) OF trace.(2_local@) ENDOF
+ ['] (3_LOCAL@) OF trace.(3_local@) ENDOF
+ ['] (4_LOCAL@) OF trace.(4_local@) ENDOF
+ ['] (5_LOCAL@) OF trace.(5_local@) ENDOF
+ ['] (6_LOCAL@) OF trace.(6_local@) ENDOF
+ ['] (7_LOCAL@) OF trace.(7_local@) ENDOF
+ ['] (8_LOCAL@) OF trace.(8_local@) ENDOF
+ ['] (LOCAL!) OF trace.(local!) ENDOF
+ ['] (1_LOCAL!) OF trace.(1_local!) ENDOF
+ ['] (2_LOCAL!) OF trace.(2_local!) ENDOF
+ ['] (3_LOCAL!) OF trace.(3_local!) ENDOF
+ ['] (4_LOCAL!) OF trace.(4_local!) ENDOF
+ ['] (5_LOCAL!) OF trace.(5_local!) ENDOF
+ ['] (6_LOCAL!) OF trace.(6_local!) ENDOF
+ ['] (7_LOCAL!) OF trace.(7_local!) ENDOF
+ ['] (8_LOCAL!) OF trace.(8_local!) ENDOF
+ ['] (LOCAL+!) OF trace.(local+!) ENDOF
+ >r xt EXECUTE r>
+ ENDCASE
+ ip
+;
+
+: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
+ ip trace.check.ip
+\ set context for word under test
+ trace.save.state1
+ here -> oldhere
+ trace.restore.state2
+ oldhere 256 + dp !
+\ get execution token
+ ip code@ -> xt
+ cell +-> ip
+\ execute token
+ xt is.primitive?
+ IF \ primitive
+ ip xt trace.do.primitive -> ip
+ ELSE \ secondary
+ trace_level trace_level_max <
+ IF
+ ip trace.>r \ threaded execution
+ 1 +-> trace_level
+ xt codebase + -> ip
+ ELSE
+ \ treat it as a primitive
+ ip xt trace.do.primitive -> ip
+ THEN
+ THEN
+\ restore original context
+ trace.rcheck
+ trace.save.state2
+ trace.restore.state1
+ oldhere dp !
+ ip
+;
+
+: TRACE.NEXT { ip | xt -- ip' }
+ trace_level 0>
+ IF
+ ip trace.do.next -> ip
+ THEN
+ trace_level 0>
+ IF
+ ip trace.show.next
+ ELSE
+ trace-stack on
+ ." Finished." cr
+ THEN
+ ip
+;
+
+}private
+
+: TRACE ( i*x <name> -- i*x , setup trace environment )
+ ' dup is.primitive?
+ IF
+ drop ." Sorry. You can't trace a primitive." cr
+ ELSE
+ 1 -> trace_level
+ trace_level -> trace_level_max
+ trace.0rp
+ >code -> trace_ip
+ trace_ip trace.show.next
+ trace-stack off
+ trace.save.state2
+ THEN
+;
+
+: s ( -- , step over )
+ trace_level -> trace_level_max
+ trace_ip trace.next -> trace_ip
+;
+
+: sd ( -- , step down )
+ trace_level 1+ -> trace_level_max
+ trace_ip trace.next -> trace_ip
+;
+
+: sm ( many -- , step many times )
+ trace_level -> trace_level_max
+ 0
+ ?DO
+ trace_ip trace.next -> trace_ip
+ LOOP
+;
+
+defer trace.user ( IP -- stop? )
+' 0= is trace.user
+
+: gd { more_levels | stop_level -- }
+ here what's trace.user u< \ has it been forgotten?
+ IF
+ ." Resetting TRACE.USER !!!" cr
+ ['] 0= is trace.user
+ THEN
+
+ more_levels 0<
+ more_levels 10 >
+ or \ 19990930 - OR was missing
+ IF
+ ." GD level out of range (0-10), = " more_levels . cr
+ ELSE
+ trace_level more_levels + -> trace_level_max
+ trace_level 1- -> stop_level
+ BEGIN
+ trace_ip trace.user \ call deferred user word
+ ?dup \ leave flag for UNTIL \ 19990930 - was DUP
+ IF
+ ." TRACE.USER returned " dup . ." so stopping execution." cr
+ ELSE
+ trace_ip trace.next -> trace_ip
+ trace_level stop_level > not
+ THEN
+ UNTIL
+ THEN
+;
+
+: g ( -- , execute until end of word )
+ 0 gd
+;
+
+: TRACE.HELP ( -- )
+ ." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
+ ." S ( -- , step over )" cr
+ ." SM ( many -- , step over many times )" cr
+ ." SD ( -- , step down )" cr
+ ." G ( -- , go to end of word )" cr
+ ." GD ( n -- , go down N levels from current level," cr
+ ." stop at end of this level )" cr
+;
+
+privatize
+
+0 [IF]
+variable var1
+100 var1 !
+: FOO dup IF 1 + . THEN 77 var1 @ + . ;
+: ZOO 29 foo 99 22 + . ;
+: ROO 92 >r 1 r@ + . r> . ;
+: MOO c" hello" count type
+ ." This is a message." cr
+ s" another message" type cr
+;
+: KOO 7 FOO ." DONE" ;
+: TR.DO 4 0 DO i . LOOP ;
+: TR.?DO 0 ?DO i . LOOP ;
+: TR.LOC1 { aa bb } aa bb + . ;
+: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
+
+[THEN]