Changeset 2904
- Timestamp:
- Mar 21, 2012 12:56:47 AM (14 months ago)
- Files:
-
- 5 edited
-
cpu/x86/kerncode.fth (modified) (3 diffs)
-
forth/lib/debug.fth (modified) (7 diffs)
-
forth/lib/decomp.fth (modified) (1 diff)
-
forth/lib/rstrace.fth (modified) (2 diffs)
-
ofw/core/ofwcore.fth (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
cpu/x86/kerncode.fth
r2719 r2904 300 300 code (?do) (s l i -- ) 301 301 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 309 303 ip ainc 80000000 # bx add rp adec bx 0 [rp] mov 310 304 bx ax sub rp adec ax 0 [rp] mov … … 314 308 \ Run time word for do 315 309 code (do) (s l i -- ) 316 [ifdef] big-endian-t317 310 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 327 313 ip ainc 80000000 # bx add rp adec bx 0 [rp] mov 328 314 bx ax sub rp adec ax 0 [rp] mov … … 345 331 code (leave) (s -- ) 346 332 mloclabel 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 348 340 c; 349 341 -
forth/lib/debug.fth
r2901 r2904 39 39 headers 40 40 false value first-time? 41 d# 10 circular-stack: locations 42 41 43 : (debug) (s low-adr hi-adr -- ) 42 44 unbug 1 cnt ! ip> ! <ip ! pnext … … 120 122 121 123 0 value stack-line 122 d# 50constant stack-column124 d# 45 constant stack-column 123 125 \ 0 0 2value result-loc 124 126 0 value result-line 125 127 0 value result-col 126 128 : 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 127 139 \ : save-result-loc ( -- ) #out @ #line @ to result-loc ; 128 140 \ : to-result-loc ( -- ) result-loc at-xy ; … … 171 183 <ip @ find-cfa .name 172 184 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 ! 173 193 ip@ debug-see 174 0 is stack-line \ So the initial stack is displayed in the right place175 194 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 176 202 then 177 203 0 show-rstack ! … … 179 205 rp@ is rp-mark 180 206 then 207 181 208 begin 182 209 step? @ if to-debug-window then … … 184 211 scrolling-debug? if 185 212 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 199 221 cr 200 222 ['] noop is indent … … 203 225 to-cmd-column 204 226 else 227 save-result-loc 228 show-partial-stack 229 205 230 ip@ ip-set-cursor 206 231 #line @ to stack-line … … 234 259 ascii \ of show-rstack @ 0= show-rstack ! false endof 235 260 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 236 263 ( default ) true swap 237 264 endcase -
forth/lib/decomp.fth
r2901 r2904 529 529 : debug-see ( apf -- ) 530 530 page-mode? >r no-page 531 d# 48 rmargin ! find-cfa ['] : page.:531 find-cfa ['] : .: 532 532 r> is page-mode? 533 533 ; -
forth/lib/rstrace.fth
r982 r2904 29 29 \ The third entry is a reasonable IP so it could be a do loop frame 30 30 \ 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 ) 41 45 then ( rs-adr n ) 42 46 then ( rs-adr n ) … … 74 78 2drop 75 79 ; 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 ; 102 defer 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 ; 76 141 headers 77 142 forth definitions -
ofw/core/ofwcore.fth
r2899 r2904 4771 4771 ' do-drop-in is do-autoload 4772 4772 [then] 4773 4774 also 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? 4791 previous
Note: See TracChangeset
for help on using the changeset viewer.
