Changeset 2913

Timestamp:

Mar 22, 2012 1:21:57 AM (14 months ago)

Author:

wmb

Message:

Debugger - improved the "up" command so it will skip past the method call machinery to find the caller that the user cares about.

Files:

• forth/lib/debug.fth (modified) (2 diffs)
• forth/lib/rstrace.fth (modified) (2 diffs)
• ofw/core/ofwcore.fth (modified) (1 diff)

forth/lib/debug.fth

@@ -76 +76 @@
 bug definitions
 headerless
-\ Go up the return stack until we find the return address left by our caller
-: caller-ip  ( rp -- ip )
-   begin
-      na1+ dup @  dup  in-dictionary?  if    ( rs-adr ip )
-         ip>token token@
-         dup ['] execute =  over defer? or  swap <ip @ body> =  or
-      else
-         drop false
-      then
-   until                                     ( rs-adr )
-   @ ip>token
-;
+\ Go up the return stack until we find an interesting caller
 : up1  ( rp -- )
-   caller-ip
-   dup find-cfa   ( ip cfa )
-   dup ['] catch = if  2drop exit  then
-   cr ." [ Up to " dup .name ." ]" cr  ( ip cfa )
-   over token@ .name                   ( ip cfa )
-   >body swap 'unnest (debug)
-;
+   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                                      ( )
+;
+
 defer to-debug-window  ' noop is to-debug-window
 defer restore-window   ' noop is restore-window
@@ -184 +186 @@
    .debug-short-help
    ." Callers: "  rp0 @ the-rp na1+ rslist kill-line cr
-   \ XXX the following is wrong when popping up
-   the-ip  <ip @ =  if  
-      #line @ is stack-line \ So the initial stack is displayed in the right place
-   then
    d# 40 rmargin !
    the-ip debug-see
    cr
-   \ When popping up from an interior word, display the initial stack on
-   \ the line where the cursor will be.
-   the-ip  <ip @ <>  if  
-      the-ip ip>position  if   ( col row )
-         drop  is stack-line   ( )
-      then
+   \ Display the initial stack on the cursor line
+   the-ip ip>position  0=  if   ( col row )
+      is stack-line   drop      ( )
    then
 ;

forth/lib/rstrace.fth

@@ -104 +104 @@
 \ $call-method that are essentially indirect calls.  Such words
 \ just clutter up the stack display and should be elided for clarity.
-defer boring?
-: (boring?)  ( ip -- flag )  drop false  ;
-' (boring?) is boring?
+defer indirect-call?
+: (indirect-call?)  ( xt -- flag )  ['] catch =  ;
+' (indirect-call?) is indirect-call?
 
 : rtraceword  ( rs-end rs-adr -- rs-end rs-adr' )
@@ -121 +121 @@
    find-cfa                    ( rs-end rs-adr xt )
 
-   dup boring?  if             ( rs-end rs-adr xt )
+   dup indirect-call?  if      ( rs-end rs-adr xt )
       drop exit                ( -- rs-end rs-adr )
    then                        ( rs-end rs-adr xt )

ofw/core/ofwcore.fth

@@ -4773 +4773 @@
 
 also hidden
-: method-call?  ( ip -- flag )
-   dup ['] $call-self =  if  drop true exit  then  ( ip )
-   dup ['] $call-method =  if  drop true exit  then  ( ip )
-   dup ['] $call-parent =  if  drop true exit  then  ( ip )
-   dup ['] call-package =  if  drop true exit  then  ( ip )
-   dup ['] $vexecute    =  if  drop true exit  then  ( ip )
-   dup ['] $vexecute?   =  if  drop true exit  then  ( ip )
-   dup ['] $package-execute? =  if  drop true exit  then  ( ip )
-   dup ['] package-execute   =  if  drop true exit  then  ( ip )
-   dup ['] apply-method      =  if  drop true exit  then  ( ip )
-   dup ['] (apply-method)    =  if  drop true exit  then  ( ip )
-   dup ['] (execute-method)  =  if  drop true exit  then  ( ip )
-   dup ['] execute-device-method  =  if  drop true exit  then  ( ip )
+: method-call?  ( xt -- flag )
+   dup (indirect-call?)  if  drop true exit  then  ( xt )
+   dup ['] $call-self =  if  drop true exit  then  ( xt )
+   dup ['] $call-method =  if  drop true exit  then  ( xt )
+   dup ['] $call-parent =  if  drop true exit  then  ( xt )
+   dup ['] call-package =  if  drop true exit  then  ( xt )
+   dup ['] $vexecute    =  if  drop true exit  then  ( xt )
+   dup ['] $vexecute?   =  if  drop true exit  then  ( xt )
+   dup ['] $package-execute? =  if  drop true exit  then  ( xt )
+   dup ['] package-execute   =  if  drop true exit  then  ( xt )
+   dup ['] apply-method      =  if  drop true exit  then  ( xt )
+   dup ['] (apply-method)    =  if  drop true exit  then  ( xt )
+   dup ['] (execute-method)  =  if  drop true exit  then  ( xt )
+   dup ['] execute-device-method  =  if  drop true exit  then  ( xt )
    drop false
 ;
-' method-call? to boring?
+' method-call? to indirect-call?
 previous