2017-04-23 22:25:49 +00:00
|
|
|
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
|
2020-07-19 06:41:36 +00:00
|
|
|
0 \ Programming-Tools word set cas 19july2020
|
2017-04-23 22:25:49 +00:00
|
|
|
1 Onlyforth \needs Assembler 2 loadfrom asm.fb
|
|
|
|
|
2
|
|
|
|
|
3 Vocabulary Tools Tools also definitions
|
|
|
|
|
4
|
2020-07-19 06:41:36 +00:00
|
|
|
5 1 11 +thru Onlyforth .( Tools loaded ) cr
|
2017-04-23 22:25:49 +00:00
|
|
|
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
|
2020-07-19 06:41:36 +00:00
|
|
|
0 \ N>R NR> cr
|
2017-04-23 22:25:49 +00:00
|
|
|
1
|
2020-07-19 06:41:36 +00:00
|
|
|
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 @ . ;
|
2017-04-23 22:25:49 +00:00
|
|
|
4
|
|
|
|
|
5
|
|
|
|
|
6
|
|
|
|
|
7
|
|
|
|
|
8
|
|
|
|
|
9
|
|
|
|
|
10
|
|
|
|
|
11
|
|
|
|
|
12
|
|
|
|
|
13
|
|
|
|
|
14
|
|
|
|
|
15
|
