mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-26 17:49:18 +00:00
222 lines
14 KiB
Forth
222 lines
14 KiB
Forth
|
\ *** Block No. 0 Hexblock 0
|
||
|
|
\ ks 22 dez 87
|
||
|
|
|
||
|
|
Some simple tools for debugging.
|
||
|
|
A state-of-the-art, interactive single step tracer
|
||
|
|
and a couple of tools for decompiling and dumping
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 1 Hexblock 1
|
||
|
|
\ Programming-Tools word set cas 19july2020
|
||
|
|
Onlyforth \needs Assembler 2 loadfrom asm.fb
|
||
|
|
|
||
|
|
Vocabulary Tools Tools also definitions
|
||
|
|
|
||
|
|
1 11 +thru Onlyforth .( Tools loaded ) cr
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 2 Hexblock 2
|
||
|
|
\ trace - next ks 11 jun 87
|
||
|
|
|
||
|
|
| Variable nest? nest? off
|
||
|
|
|
||
|
|
Label tracenext 0 # nest? #) byte cmp 0=
|
||
|
|
?[ $5555 # I cmp here 2- >label (ip >=
|
||
|
|
?[ [[ swap lods A W xchg W ) jmp ]?
|
||
|
|
$5555 # I cmp here 2- >label ip) CS ?]
|
||
|
|
][ 0 # nest? #) byte mov
|
||
|
|
]? $5555 # W mov here 2- >label >tracing W ) jmp
|
||
|
|
end-code
|
||
|
|
|
||
|
|
| (ip Constant <ip | ip) Constant ip>
|
||
|
|
|
||
|
|
| : (debug ( addr -- ) dup <ip !
|
||
|
|
BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
|
||
|
|
\ *** Block No. 3 Hexblock 3
|
||
|
|
\ install Tracer ks 11 jun 87
|
||
|
|
|
||
|
|
Label (do-trace next-link # W mov D push
|
||
|
|
$E9 # A- mov tracenext 1+ # C mov
|
||
|
|
[[ W ) W mov W W or 0= not
|
||
|
|
?[[ A- -4 W D) mov C D mov W D sub
|
||
|
|
D -3 W D) mov ]]? D pop ret end-code
|
||
|
|
|
||
|
|
Code do-trace (do-trace # call Next end-code
|
||
|
|
|
||
|
|
' end-trace Alias end-trace
|
||
|
|
|
||
|
|
| Code (step (do-trace # call
|
||
|
|
R ) I mov R inc R inc lods A W xchg W ) jmp
|
||
|
|
|
||
|
|
| Create: nextstep (step ;
|
||
|
|
\ *** Block No. 4 Hexblock 4
|
||
|
|
\ tracer display ks 20 sep 88
|
||
|
|
|
||
|
|
| Variable nest# nest# off
|
||
|
|
|
||
|
|
| Variable 'ip 'ip off
|
||
|
|
|
||
|
|
| Create: -nest r> ip> ! r> <ip ! -1 nest# +! ;
|
||
|
|
|
||
|
|
| : oneline .status space
|
||
|
|
BEGIN query interpret tib #tib @ + 1- c@ BL =
|
||
|
|
WHILE prompt &36 tab REPEAT
|
||
|
|
-$20 allot r0 @ rp! r> r0 ! r> dup #tib !
|
||
|
|
rp@ over tib swap cmove rp@ + rp!
|
||
|
|
r> Is parser r> adr 'quit ! r> >in !
|
||
|
|
r> blk ! r> state ! r> output ! r> input ! ;
|
||
|
|
|
||
|
|
\ *** Block No. 5 Hexblock 5
|
||
|
|
\ tracer display ks 16 sep 88
|
||
|
|
|
||
|
|
| : tracing end-trace nest? @
|
||
|
|
IF r> <ip @ >r ip> @ >r -nest >r >r
|
||
|
|
1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip !
|
||
|
|
nextstep >r input @ >r output @ >r state @ >r
|
||
|
|
blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r
|
||
|
|
tib #tib @ rp@ over - under rp! cmove #tib @ >r
|
||
|
|
r0 @ >r rp@ r0 ! standardi/o
|
||
|
|
cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r
|
||
|
|
2 spaces >name .name &30 nest# @ + tab .s
|
||
|
|
$20 allot ['] oneline Is 'quit quit ;
|
||
|
|
' tracing >tracing !
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 6 Hexblock 6
|
||
|
|
\ test traceability ks 07 dez 87
|
||
|
|
|
||
|
|
| : traceable ( cfa -- cfa' ) recursive dup @
|
||
|
|
[ ' : @ ] Literal case? ?exit
|
||
|
|
[ ' key @ ] Literal case? IF >body c@ Input @ +
|
||
|
|
@ traceable exit THEN
|
||
|
|
[ ' type @ ] Literal case? IF >body c@ Output @ +
|
||
|
|
@ traceable exit THEN
|
||
|
|
[ ' r/w @ ] Literal case? IF >body @ traceable exit THEN
|
||
|
|
c@ $E9 = IF @ 1+ exit THEN \ Does> word
|
||
|
|
>name .name ." can't be DEBUGged" quit ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 7 Hexblock 7
|
||
|
|
\ user words for tracing ks 16 sep 88
|
||
|
|
| : do_debug ( addr -- )
|
||
|
|
traceable (debug nest? off nest# off do-trace ;
|
||
|
|
|
||
|
|
: nest \ trace next high-level word executed
|
||
|
|
'ip @ @ traceable drop nest? on ;
|
||
|
|
|
||
|
|
: unnest \ ends tracing of actual word
|
||
|
|
<ip on ip> off ; unnest \ clears trap range
|
||
|
|
|
||
|
|
: endloop \ stop tracing loop
|
||
|
|
'ip @ <ip ! ; \ use when at end of loop
|
||
|
|
|
||
|
|
: debug ' do_debug ;
|
||
|
|
|
||
|
|
: trace ' dup >r do_debug r> execute end-trace unnest ;
|
||
|
|
\ *** Block No. 8 Hexblock 8
|
||
|
|
\ tools for decompiling, interactive use ks 04 jul 87
|
||
|
|
|
||
|
|
| : ?: ( addr -- addr ) dup 5 u.r ." :" ;
|
||
|
|
| : @? ( addr -- addr ) dup @ 6 u.r ;
|
||
|
|
| : c? ( addr -- addr ) dup c@ 3 .r ;
|
||
|
|
| : end $28 tab ;
|
||
|
|
|
||
|
|
: s ( addr1 -- addr2 )
|
||
|
|
?: 3 spaces c? 2 spaces count 2dup type + even end ;
|
||
|
|
: n ( addr1 -- addr2 )
|
||
|
|
?: @? 2 spaces dup @ >name .name 2+ end ;
|
||
|
|
: d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces
|
||
|
|
swap 0 DO c? 1+ LOOP 2 spaces -rot type end ;
|
||
|
|
: l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ;
|
||
|
|
: c ( addr1 -- addr2 ) 1 d end ;
|
||
|
|
: b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ;
|
||
|
|
\ *** Block No. 9 Hexblock 9
|
||
|
|
\ often times ks 29 jun 87
|
||
|
|
Onlyforth
|
||
|
|
|
||
|
|
: often stop? ?exit >in off ;
|
||
|
|
|
||
|
|
| Variable #times #times off
|
||
|
|
|
||
|
|
: times ( n -- ) ?dup
|
||
|
|
IF #times @ 2+ u< stop? or
|
||
|
|
IF #times off exit THEN 1 #times +!
|
||
|
|
ELSE stop? ?exit
|
||
|
|
THEN >in off ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 10 Hexblock A
|
||
|
|
\ dump ks 04 jul 87
|
||
|
|
|
||
|
|
: dump ( addr n -- ) base push hex
|
||
|
|
bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop
|
||
|
|
stop? IF LEAVE THEN $10 +LOOP ;
|
||
|
|
|
||
|
|
| : ld ( seg:addr -- )
|
||
|
|
over 4 u.r ." :" dup 0 <# # # # # #> type
|
||
|
|
3 spaces ds@ pad $10 lmove pad $10 bounds
|
||
|
|
DO I c@ 3 u.r LOOP 2 spaces pad $10 type ;
|
||
|
|
|
||
|
|
: ldump ( seg:addr quan -- ) base push hex
|
||
|
|
0 DO cr 2dup ld $10 + stop? IF LEAVE THEN
|
||
|
|
$10 +LOOP 2drop ;
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 11 Hexblock B
|
||
|
|
\ N>R NR> cr
|
||
|
|
|
||
|
|
: N>R ( i * n +n -- ) ( R: -- j * x +n )
|
||
|
|
\ Transfer N items and count to the return stack.
|
||
|
|
DUP BEGIN DUP WHILE
|
||
|
|
ROT R> SWAP >R >R
|
||
|
|
1-
|
||
|
|
REPEAT DROP R> SWAP >R >R ;
|
||
|
|
|
||
|
|
: NR> ( -- i * x +n ) ( R: j * x +n -- )
|
||
|
|
\ Pull N items and count off the return stack.
|
||
|
|
R> R> SWAP >R DUP
|
||
|
|
BEGIN DUP WHILE
|
||
|
|
R> R> SWAP >R -ROT
|
||
|
|
1-
|
||
|
|
REPEAT DROP ;
|
||
|
|
\ *** Block No. 12 Hexblock C
|
||
|
|
\ ?
|
||
|
|
: ? ( a-addr -- )
|
||
|
|
\ Display the value stored at a-addr.
|
||
|
|
@ . ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|