X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/a1f4e52df60d8f26327ed57f5a9e7b70d0a04273..8e9db35f299d8f606ba003d3cd8fa9e2c868c880:/fth/trace.fth diff --git a/fth/trace.fth b/fth/trace.fth index 26078d0..c311bc4 100644 --- a/fth/trace.fth +++ b/fth/trace.fth @@ -1,460 +1,460 @@ -\ @(#) trace.fth 98/01/28 1.2 -\ TRACE ( -- , trace pForth word ) -\ -\ Single step debugger. -\ TRACE ( i*x -- , 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 -- 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 -- , 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] +\ @(#) trace.fth 98/01/28 1.2 +\ TRACE ( -- , trace pForth word ) +\ +\ Single step debugger. +\ TRACE ( i*x -- , 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 -- 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 -- , 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]