r974 - forth/lib

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
 \