VolksForth/sources/msdos/tools.fb.src

222 lines
14 KiB
Plaintext

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