Author: wmb Date: 2008-10-04 02:10:44 +0200 (Sat, 04 Oct 2008) New Revision: 974
Modified: forth/lib/rstrace.fth Log: Generic rstrace command - decode do loop indices and catch frames.
Modified: forth/lib/rstrace.fth =================================================================== --- forth/lib/rstrace.fth 2008-10-04 00:10:41 UTC (rev 973) +++ forth/lib/rstrace.fth 2008-10-04 00:10:44 UTC (rev 974) @@ -12,18 +12,57 @@ decimal only forth also hidden also definitions headerless +: @+ ( adr -- adr' n ) dup na1+ swap @ ; : .last-executed ( ip -- ) ip>token token@ ( acf ) dup reasonable-ip? if .name else drop ." ??" then ; -: .traceline ( ipaddr -- ) - push-hex - dup reasonable-ip? - if dup .last-executed ip>token .caller else 9 u.r then cr +: in-catch? ( ip -- flag ) find-cfa ['] catch = ; +: .catch ( rs-adr -- rs-adr' ) + ." Catch frame - SP: " @+ . ." my-self: " @+ . ." handler: " @+ . +; +1 bits/cell 1- lshift constant minus0 +: .do-or-n ( rs-adr n -- rs-adr' ) + over @ reasonable-ip? 0= if ( rs-adr n ) + \ The second number is not an IP so it could be a do loop frame + over na1+ @ reasonable-ip? if ( rs-adr n ) + \ The third entry is a reasonable IP so it could be a do loop frame + \ Make sure it points just past a loop end + over na1+ @ ( rs-adr n n2 ) + ip>token -1 na+ token@ ( rs-adr n xt ) + dup ['] (loop) = swap ['] (+loop) = or if ( rs-adr n ) + \ The two numbers span the +- boundary, so probably a do loop + ." Do loop frame inside " + over na1+ @ ip>token .current-word ( rs-adr n ) + over @ ( rs-adr n n1 ) + ." i: " tuck + . ( rs-adr n1 ) + ." limit: " minus0 + . ( rs-adr ) + 2 na+ exit + then ( rs-adr n ) + then ( rs-adr n ) + then ( rs-adr n ) + 9 u.r +; +: .traceline ( rs-adr -- rs-adr' ) + push-hex ( rs-adr ) + @+ ( rs-adr' ip ) + dup reasonable-ip? if ( rs-adr ip ) + dup in-catch? if ( rs-adr ip ) + drop .catch ( rs-adr' ) + else ( rs-adr ip ) + dup .last-executed ip>token .caller ( rs-adr ) + then ( rs-adr ) + else ( rs-adr ip ) + .do-or-n ( rs-adr ) + then cr ( rs-adr ) pop-base ; -: (rstrace ( bottom-adr top-adr -- ) - do i @ .traceline exit? ?leave /n +loop +: (rstrace ( end-adr start-adr -- ) + begin 2dup u> while ( end-adr adr ) + .traceline ( end-adr adr' ) + exit? if 2drop exit then ( end-adr adr ) + repeat ( end-adr adr ) + 2drop ; headers forth definitions @@ -35,6 +74,7 @@ then ; only forth also definitions + \ LICENSE_BEGIN \ Copyright (c) 2006 FirmWorks \