Changeset 2904


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