Changeset 2913


Ignore:
Timestamp:
Mar 22, 2012, 1:21:57 AM (2 years 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:
3 edited

Legend:

Unmodified
Added
Removed
  • forth/lib/debug.fth

    r2910 r2913  
    7676bug definitions 
    7777headerless 
    78 \ Go up the return stack until we find the return address left by our caller 
    79 : caller-ip  ( rp -- ip ) 
    80    begin 
    81       na1+ dup @  dup  in-dictionary?  if    ( rs-adr ip ) 
    82          ip>token token@ 
    83          dup ['] execute =  over defer? or  swap <ip @ body> =  or 
    84       else 
    85          drop false 
    86       then 
    87    until                                     ( rs-adr ) 
    88    @ ip>token 
    89 ; 
     78\ Go up the return stack until we find an interesting caller 
    9079: up1  ( rp -- ) 
    91    caller-ip 
    92    dup find-cfa   ( ip cfa ) 
    93    dup ['] catch = if  2drop exit  then 
    94    cr ." [ Up to " dup .name ." ]" cr  ( ip cfa ) 
    95    over token@ .name                   ( ip cfa ) 
    96    >body swap 'unnest (debug) 
    97 ; 
     80   begin  na1+  dup rp0 @ <>  while          ( rs-adr ) 
     81      dup @                                  ( rs-adr ip ) 
     82      dup in-dictionary?  if                 ( rs-adr ip ) 
     83         find-cfa  dup indirect-call?  if    ( rs-adr xt ) 
     84            drop                             ( rs-adr ) 
     85         else                                ( rs-adr xt ) 
     86            nip                              ( rs-adr ) 
     87            scrolling-debug?  if             ( xt ) 
     88               cr ." [ Up to " dup .name ." ]" cr 
     89            then                             ( xt ) 
     90            (debug                           ( ) 
     91            exit                             ( -- ) 
     92         then                                ( rs-adr ) 
     93      else                                   ( rs-adr ip ) 
     94         drop                                ( rs-adr ) 
     95      then                                   ( rs-adr ) 
     96   repeat                                    ( rs-adr ) 
     97   drop                                      ( ) 
     98; 
     99 
    98100defer to-debug-window  ' noop is to-debug-window 
    99101defer restore-window   ' noop is restore-window 
     
    184186   .debug-short-help 
    185187   ." Callers: "  rp0 @ the-rp na1+ rslist kill-line cr 
    186    \ XXX the following is wrong when popping up 
    187    the-ip  <ip @ =  if   
    188       #line @ is stack-line \ So the initial stack is displayed in the right place 
    189    then 
    190188   d# 40 rmargin ! 
    191189   the-ip debug-see 
    192190   cr 
    193    \ When popping up from an interior word, display the initial stack on 
    194    \ the line where the cursor will be. 
    195    the-ip  <ip @ <>  if   
    196       the-ip ip>position  if   ( col row ) 
    197          drop  is stack-line   ( ) 
    198       then 
     191   \ Display the initial stack on the cursor line 
     192   the-ip ip>position  0=  if   ( col row ) 
     193      is stack-line   drop      ( ) 
    199194   then 
    200195; 
  • forth/lib/rstrace.fth

    r2911 r2913  
    104104\ $call-method that are essentially indirect calls.  Such words 
    105105\ just clutter up the stack display and should be elided for clarity. 
    106 defer boring? 
    107 : (boring?)  ( ip -- flag )  drop false  ; 
    108 ' (boring?) is boring? 
     106defer indirect-call? 
     107: (indirect-call?)  ( xt -- flag )  ['] catch =  ; 
     108' (indirect-call?) is indirect-call? 
    109109 
    110110: rtraceword  ( rs-end rs-adr -- rs-end rs-adr' ) 
     
    121121   find-cfa                    ( rs-end rs-adr xt ) 
    122122 
    123    dup boring?  if             ( rs-end rs-adr xt ) 
     123   dup indirect-call?  if      ( rs-end rs-adr xt ) 
    124124      drop exit                ( -- rs-end rs-adr ) 
    125125   then                        ( rs-end rs-adr xt ) 
  • ofw/core/ofwcore.fth

    r2904 r2913  
    47734773 
    47744774also hidden 
    4775 : method-call?  ( ip -- flag ) 
    4776    dup ['] $call-self =  if  drop true exit  then  ( ip ) 
    4777    dup ['] $call-method =  if  drop true exit  then  ( ip ) 
    4778    dup ['] $call-parent =  if  drop true exit  then  ( ip ) 
    4779    dup ['] call-package =  if  drop true exit  then  ( ip ) 
    4780    dup ['] $vexecute    =  if  drop true exit  then  ( ip ) 
    4781    dup ['] $vexecute?   =  if  drop true exit  then  ( ip ) 
    4782    dup ['] $package-execute? =  if  drop true exit  then  ( ip ) 
    4783    dup ['] package-execute   =  if  drop true exit  then  ( ip ) 
    4784    dup ['] apply-method      =  if  drop true exit  then  ( ip ) 
    4785    dup ['] (apply-method)    =  if  drop true exit  then  ( ip ) 
    4786    dup ['] (execute-method)  =  if  drop true exit  then  ( ip ) 
    4787    dup ['] execute-device-method  =  if  drop true exit  then  ( ip ) 
     4775: method-call?  ( xt -- flag ) 
     4776   dup (indirect-call?)  if  drop true exit  then  ( xt ) 
     4777   dup ['] $call-self =  if  drop true exit  then  ( xt ) 
     4778   dup ['] $call-method =  if  drop true exit  then  ( xt ) 
     4779   dup ['] $call-parent =  if  drop true exit  then  ( xt ) 
     4780   dup ['] call-package =  if  drop true exit  then  ( xt ) 
     4781   dup ['] $vexecute    =  if  drop true exit  then  ( xt ) 
     4782   dup ['] $vexecute?   =  if  drop true exit  then  ( xt ) 
     4783   dup ['] $package-execute? =  if  drop true exit  then  ( xt ) 
     4784   dup ['] package-execute   =  if  drop true exit  then  ( xt ) 
     4785   dup ['] apply-method      =  if  drop true exit  then  ( xt ) 
     4786   dup ['] (apply-method)    =  if  drop true exit  then  ( xt ) 
     4787   dup ['] (execute-method)  =  if  drop true exit  then  ( xt ) 
     4788   dup ['] execute-device-method  =  if  drop true exit  then  ( xt ) 
    47884789   drop false 
    47894790; 
    4790 ' method-call? to boring? 
     4791' method-call? to indirect-call? 
    47914792previous 
Note: See TracChangeset for help on using the changeset viewer.