Changeset 2904


Ignore:
Timestamp:
Mar 21, 2012, 12:56:47 AM (2 years ago)
Author:
wmb
Message:

Improvements to the 2D debugger.

Files:
5 edited

Legend:

Unmodified
Added
Removed
  • cpu/x86/kerncode.fth

    r2719 r2904  
    300300code (?do)  (s l i -- ) 
    301301   ax pop   bx pop   ax bx cmp  = if  bran1 #) jmp  then 
    302 [ifdef] big-endian-t 
    303    bx push  ax push 
    304    ip dx mov    0 [ip] ax mov  ?bswap-ax  ax dx add   rp adec   dx 0 [rp] mov 
    305    ax pop   bx pop      \ i in ax  l in bx 
    306 [else] 
    307    ip dx mov    0 [ip] dx add   rp adec   dx 0 [rp] mov 
    308 [then] 
     302   rp adec   ip 0 [rp] mov 
    309303   ip ainc  80000000 # bx add   rp adec   bx 0 [rp] mov 
    310304   bx ax sub                    rp adec   ax 0 [rp] mov 
     
    314308\ Run time word for do 
    315309code (do)  (s l i -- ) 
    316 [ifdef] big-endian-t 
    317310   ax pop   bx pop      \ i in ax  l in bx 
    318  
    319    bx push  ax push 
    320    ip dx mov    0 [ip] ax mov  ?bswap-ax  ax dx add   rp adec   dx 0 [rp] mov 
    321    ax pop   bx pop      \ i in ax  l in bx 
    322 [else] 
    323    ax pop   bx pop      \ i in ax  l in bx 
    324     
    325    ip dx mov    0 [ip] dx add   rp adec   dx 0 [rp] mov 
    326 [then] 
     311   rp adec   ip 0 [rp] mov 
     312 
    327313   ip ainc  80000000 # bx add   rp adec   bx 0 [rp] mov 
    328314   bx ax sub                    rp adec   ax 0 [rp] mov 
     
    345331code (leave)  (s -- ) 
    346332mloclabel pleave 
    347    2 /n* [rp] ip mov   3 /n* # rp add 
     333   2 /n* [rp] ip mov 
     334[ifdef] big-endian-t 
     335   0 [ip] ax mov  ?bswap-ax  ax ip add    
     336[else] 
     337   0 [ip] ip add   
     338[then] 
     339   3 /n* # rp add 
    348340c; 
    349341 
  • forth/lib/debug.fth

    r2901 r2904  
    3939headers 
    4040false value first-time? 
     41d# 10 circular-stack: locations 
     42 
    4143: (debug)       (s low-adr hi-adr -- ) 
    4244   unbug   1 cnt !   ip> !   <ip !   pnext 
     
    120122 
    1211230 value stack-line 
    122 d# 50 constant stack-column 
     124d# 45 constant stack-column 
    123125\ 0 0 2value result-loc 
    1241260 value result-line 
    1251270 value result-col 
    126128: to-stack-location  ( -- )  stack-column stack-line at-xy  kill-line  ; 
     129: show-partial-stack  ( -- ) 
     130   to-stack-location 
     131 
     132   ." \ " 
     133   depth 0<  if  ." Stack Underflow" sp0 @ sp!  exit  then 
     134   depth 0=  if  ." Empty"  exit  then 
     135   depth 4 >  if  ." .. "  then 
     136   depth  depth 5 - 0 max  ?do  depth i - 1- pick n.  loop 
     137; 
     138 
    127139\ : save-result-loc  ( -- )  #out @ #line @ to result-loc  ; 
    128140\ : to-result-loc  ( -- )  result-loc at-xy  ; 
     
    171183         <ip @ find-cfa .name 
    172184      else 
     185         page 
     186         d# 78 rmargin ! 
     187         ." Callers: "  rp0 @ rp@ na1+ rslist kill-line cr 
     188         \ XXX the following is wrong when popping up 
     189         ip@  <ip @ =  if   
     190            #line @ is stack-line \ So the initial stack is displayed in the right place 
     191         then 
     192         d# 40 rmargin ! 
    173193         ip@ debug-see 
    174          0 is stack-line \ So the initial stack is displayed in the right place 
    175194         cr 
     195\         ip@  <ip @ <>  if   
     196\            ip@ ip>position  if   ( col row ) 
     197\               swap  
     198\               is stack-line 
     199\            then 
     200\            #line @ is stack-line \ So the initial stack is displayed in the right place 
     201 \        then 
    176202      then 
    177203      0 show-rstack ! 
     
    179205      rp@ is rp-mark 
    180206   then 
     207 
    181208   begin 
    182209      step? @  if  to-debug-window  then 
     
    184211      scrolling-debug?  if 
    185212         cmd-column 2+ to-column 
    186       else 
    187          save-result-loc 
    188          to-stack-location 
    189       then 
    190  
    191       hex-stack @  if  push-hex  then 
    192       ." ( " .s    \ Show data stack 
    193       hex-stack @  if  pop-base  then 
    194       show-rstack @  if  (.rs  then   \ Show return stack 
    195       ." )" 
    196       restore# 
    197  
    198       scrolling-debug?  if 
     213 
     214         hex-stack @  if  push-hex  then 
     215         ." ( " .s    \ Show data stack 
     216         hex-stack @  if  pop-base  then 
     217         show-rstack @  if  (.rs  then   \ Show return stack 
     218         ." )" 
     219         restore# 
     220 
    199221         cr 
    200222         ['] noop is indent 
     
    203225         to-cmd-column 
    204226      else 
     227         save-result-loc 
     228         show-partial-stack 
     229         
    205230         ip@ ip-set-cursor 
    206231         #line @ to stack-line 
     
    234259            ascii \  of  show-rstack @ 0= show-rstack ! false endof 
    235260            ascii X  of  hex-stack @ 0= hex-stack !   false  endof 
     261            ascii V  of  scrolling-debug? 0= to scrolling-debug? 
     262                         scrolling-debug? 0=  if  true to first-time?  then  false  endof 
    236263            ( default )  true swap 
    237264         endcase 
  • forth/lib/decomp.fth

    r2901 r2904  
    529529: debug-see    ( apf -- ) 
    530530   page-mode? >r  no-page 
    531    d# 48 rmargin !  find-cfa ['] :  page  .: 
     531   find-cfa ['] :  .: 
    532532   r> is page-mode? 
    533533; 
  • forth/lib/rstrace.fth

    r982 r2904  
    2929         \ The third entry is a reasonable IP so it could be a do loop frame 
    3030         \ Make sure it points just past a loop end 
    31          over na1+ @                          ( rs-adr n n2 ) 
    32          ip>token  -1 na+  token@             ( rs-adr n xt ) 
    33          dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n ) 
    34             \ The two numbers span the +- boundary, so probably a do loop 
    35             ."    Do loop frame inside " 
    36             over na1+ @ ip>token .current-word ( rs-adr n ) 
    37             over @                             ( rs-adr n n1 ) 
    38             ."   i: "  tuck + .                ( rs-adr n1 ) 
    39             ."   limit: "  minus0  + .         ( rs-adr ) 
    40             2 na+ exit 
     31         over na1+ @  dup @ +                 ( rs-adr n n2 ) 
     32         dup reasonable-ip?  if               ( rs-adr n adr ) 
     33            ip>token  -1 na+  token@          ( rs-adr n xt ) 
     34            dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n ) 
     35               \ The two numbers span the +- boundary, so probably a do loop 
     36               ."    Do loop frame inside " 
     37               over na1+ @ ip>token .current-word ( rs-adr n ) 
     38               over @                             ( rs-adr n n1 ) 
     39               ."   i: "  tuck + .                ( rs-adr n1 ) 
     40               ."   limit: "  minus0  + .         ( rs-adr ) 
     41               2 na+ exit 
     42            then                               ( rs-adr n ) 
     43         else                                  ( rs-adr n n2 ) 
     44            drop                               ( rs-adr n ) 
    4145         then                                  ( rs-adr n ) 
    4246      then                                     ( rs-adr n ) 
     
    7478    2drop 
    7579; 
     80: skip-catch  ( rs-adr -- rs-adr' )  3 na+  ; 
     81: skip-do-or-n  ( rs-adr n -- rs-adr' ) 
     82   over @ reasonable-ip?  0=  if              ( rs-adr n ) 
     83      \ The second number is not an IP so it could be a do loop frame 
     84      over na1+ @  reasonable-ip?  if         ( rs-adr n ) 
     85         \ The third entry is a reasonable IP so it could be a do loop frame 
     86         \ Make sure it points to an offset that points just past a loop end 
     87         over na1+ @  dup @ +                 ( rs-adr n n2 ) 
     88         dup reasonable-ip?  if               ( rs-adr n adr ) 
     89            ip>token  -1 na+  token@          ( rs-adr n xt ) 
     90            dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n ) 
     91               \ The two numbers span the +- boundary, so probably a do loop 
     92               drop                           ( rs-adr ) 
     93               2 na+ exit                     ( -- rs-adr ) 
     94            then                              ( rs-adr n ) 
     95         else                                 ( rs-adr n n2 ) 
     96            drop                              ( rs-adr n ) 
     97         then                                 ( rs-adr n ) 
     98      then                                    ( rs-adr n ) 
     99   then                                       ( rs-adr n ) 
     100   drop                                       ( rs-adr ) 
     101; 
     102defer boring? 
     103: (boring?)  ( ip -- flag )  drop false  ; 
     104: rtraceword  ( rs-end rs-adr -- rs-end rs-adr' ) 
     105   @+                          ( rs-end rs-adr' ip ) 
     106   dup reasonable-ip?  0=  if  ( rs-end rs-adr ip ) 
     107      skip-do-or-n exit        ( -- rs-end rs-adr ) 
     108   then                        ( rs-end rs-adr ) 
     109 
     110   dup in-catch?  if           ( rs-end rs-adr ip ) 
     111      drop skip-catch          ( rs-end rs-adr' ) 
     112      exit                     ( -- rs-end rs-adr' ) 
     113   then                        ( rs-end rs-adr ip ) 
     114 
     115   find-cfa                    ( rs-end rs-adr xt ) 
     116 
     117   dup boring?  if             ( rs-end rs-adr xt ) 
     118      drop exit                ( -- rs-end rs-adr ) 
     119   then                        ( rs-end rs-adr xt ) 
     120 
     121   dup ['] interpret-do-defined =  if  ( rs-end rs-adr xt ) 
     122      \ Set rs-adr = rs-end so the caller will exit 
     123      2drop dup exit           ( -- rs-end rs-adr' ) 
     124   then                        ( rs-end rs-adr xt ) 
     125 
     126   >name name>string           ( rs-end rs-adr adr len ) 
     127   dup #out @ +  rmargin @  >=  if  ( rs-end rs-adr adr len ) 
     128      \ Set rs-adr = rs-end so the caller will exit 
     129      2drop ." ..."            ( rs-end rs-adr ) 
     130      drop dup exit            ( -- rs-end rs-adr' ) 
     131   then                        ( rs-end rs-adr adr len ) 
     132 
     133   type space                  ( rs-end rs-adr ) 
     134; 
     135: rslist  ( end-adr start-adr -- ) 
     136   begin  2dup u>  while           ( end-adr adr ) 
     137      rtraceword                   ( end-adr adr' ) 
     138   repeat                          ( end-adr adr ) 
     139   2drop 
     140; 
    76141headers 
    77142forth definitions 
  • ofw/core/ofwcore.fth

    r2899 r2904  
    47714771' do-drop-in is do-autoload 
    47724772[then] 
     4773 
     4774also 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 ) 
     4788   drop false 
     4789; 
     4790' method-call? to boring? 
     4791previous 
Note: See TracChangeset for help on using the changeset viewer.