Changeset 2913


Ignore:
Timestamp:
Mar 22, 2012, 12:21:57 AM (3 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.