Changeset 3346

Timestamp:

Oct 2, 2012 2:59:50 AM (9 months ago)

Author:

wmb

Message:

Debugger - the "up" keystroke ('U') was not working when debugging inside a do .. loop due to misinterpreting a pointer to the loop end address as a return address.

Location:

forth/lib

Files:

• debug.fth (modified) (1 diff)
• rstrace.fth (modified) (1 diff)

forth/lib/debug.fth

@@ -88 +88 @@
 \ Go up the return stack until we find an interesting caller
 : up1  ( rp -- )
-   begin  na1+  dup rp0 @ <>  while          ( rs-adr )
-      dup @                                  ( rs-adr ip )
-      dup in-dictionary?  if                 ( rs-adr ip )
-         find-cfa  dup indirect-call?  if    ( rs-adr xt )
-            drop                             ( rs-adr )
-         else                                ( rs-adr xt )
-            nip                              ( rs-adr )
-            scrolling-debug?  if             ( xt )
-               cr ." [ Up to " dup .name ." ]" cr
-            then                             ( xt )
-            (debug                           ( )
-            exit                             ( -- )
-         then                                ( rs-adr )
-      else                                   ( rs-adr ip )
-         drop                                ( rs-adr )
-      then                                   ( rs-adr )
-   repeat                                    ( rs-adr )
-   drop                                      ( )
+   begin  na1+  dup rp0 @ <>  while             ( rs-adr )
+      dup @                                     ( rs-adr ip )
+      dup in-dictionary?  if                    ( rs-adr ip )
+         dup loop-end?  if                      ( rs-adr ip )
+            drop                                ( rs-adr )
+         else                                   ( rs-adr ip )
+            find-cfa  dup indirect-call?  if    ( rs-adr xt )
+               drop                             ( rs-adr )
+            else                                ( rs-adr xt )
+               nip                              ( rs-adr )
+               scrolling-debug?  if             ( xt )
+                  cr ." [ Up to " dup .name ." ]" cr
+               then                             ( xt )
+               (debug                           ( )
+               exit                             ( -- )
+            then                                ( rs-adr )
+         then                                   ( rs-adr )
+      else                                      ( rs-adr )
+         drop                                   ( rs-adr )
+      then                                      ( rs-adr )
+   repeat                                       ( rs-adr )
+   drop                                         ( )
 ;
 

forth/lib/rstrace.fth

@@ -23 +23 @@
 ;
 1 bits/cell 1- lshift constant minus0
+: loop-end?  ( adr -- flag )
+   dup reasonable-ip?  0=  if    ( adr )
+      drop false exit            ( -- false )
+   then                          ( adr )
+   dup @ +                       ( adr' )
+   dup reasonable-ip?  0=  if    ( adr )
+      drop false exit            ( -- false )
+   then                          ( adr )
+   ip>token  -1 na+  token@      ( xt )
+   dup ['] (loop) =  swap ['] (+loop) =  or  ( flag )
+;
+
 : .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+ @  dup @ +                 ( rs-adr n n2 )
-         dup reasonable-ip?  if               ( rs-adr n adr )
-            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 )
-         else                                  ( rs-adr n n2 )
-            drop                               ( rs-adr n )
-         then                                  ( rs-adr n )
-      then                                     ( rs-adr n )
-   then                                        ( rs-adr n )
+      over na1+ @                             ( rs-adr n n2 )
+      dup loop-end?  if                       ( rs-adr n n2 )
+         ."    Do loop frame inside "
+         ip>token .current-word               ( rs-adr n )
+         over @                               ( rs-adr n n1 )
+         ."   i: "  tuck + .                  ( rs-adr n1 )
+         ."   limit: "  minus0  + .           ( rs-adr )
+         2 na+ exit                           ( -- rs-adr' )
+      then                                    ( rs-adr n n2 )
+      drop                                    ( rs-adr n )
+   then                                       ( rs-adr n )
    9 u.r
 ;