VolksForth/sources/cpm/tools.fth

307 lines
19 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\\ Tools 11Nov86
Dieses File enthaelt die wichtigsten Werkzeuge zur Programm-
entwicklung: - den einfachen Decompiler
- der DUMP-Befehl
- den Tracer
Der einfache Decompiler wird benutzt, um neue Defining-Words
zu ueberpruefen. Der automatische Decompiler kann ja dafuer
nicht benutzt werden, da ihm diese Strukturen unbekannt sind.
(Benutzung: addr und dann, je nach Art: S N D L C oder B)
DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP)
Der Tracer erlaubt Einzelschrittausfuehrung von Worten.
Er ist unentbehrliches Hilfsmittel bei der Fehlersuche.
(Benutzung: DEBUG <name> und END-TRACE)
\ *** Block No. 1 Hexblock 1
\ Programming-Tools word set / tracer cas 19july2020
Onlyforth Vocabulary Tools Tools also definitions
01 05 +thru &15 &16 +thru
06 +load \ Tracer
Onlyforth
: internal \ start headerless definitions
1 ?head ! ;
: external \ end headerless definitions
?head off ;
\ *** Block No. 2 Hexblock 2
\ Tools for decompiling 22feb86
| : ?: dup 4 u.r ." :" ;
| : @? dup @ 6 u.r ;
| : c? dup c@ 3 .r ;
: s ( adr - adr+ )
?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ;
: n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ;
: d ( adr n - adr+n)
2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ;
\ *** Block No. 3 Hexblock 3
\ Tools for decompiling 22feb86
: l ( adr - adr+2 ) ?: 5 spaces @? 2+ ;
: c ( adr - adr+1) 1 d ;
: b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ;
\\
: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE
THEN 10 +LOOP ;
\ *** Block No. 4 Hexblock 4
\ General Dump Utility - Output UH 07Jun86
| : .2 ( n -- ) 0 <# # # #> type space ;
| : .6 ( d -- ) <# # # # # # # #> type ;
| : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ;
| : emit. ( char -- )
$7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ;
| : dln ( addr --- )
cr dup 6 u.r 2 spaces 8 2dup d.2 space
over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ;
| : ?.n ( n1 n2 -- n1 )
2dup = IF ." \/" drop ELSE 2 .r THEN space ;
| : ?.a ( n1 n2 -- n1 )
2dup = IF ." V" drop ELSE 1 .r THEN ;
\ *** Block No. 5 Hexblock 5
\ .head UH 03Jun86
| : .head ( addr len -- addr' len' )
swap dup -$10 and swap $0F and cr 8 spaces
8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP
space $10 0 DO I ?.a LOOP rot + ;
\ *** Block No. 6 Hexblock 6
\ Dump and Fill Memory Utility UH 25Aug86
Forth definitions
: dump ( addr len -- )
base push hex .head
bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ;
Tools definitions
: du ( addr -- addr+$40 ) dup $40 dump $40 + ;
: dl ( line# -- ) c/l * scr @ block + c/l dump ;
Forth definitions
\ *** Block No. 7 Hexblock 7
\ Trace Loadscreen 29Jun86
Onlyforth \needs Tools Vocabulary Tools
Tools also definitions
1 8 +thru
Onlyforth
\ clear
\ don't forget END-TRACE after using DEBUG
\ *** Block No. 8 Hexblock 8
\ Variables do-trace UH 04Nov86
| Variable Wsave \ Variable for saving W
| Variable <ip \ start of trace trap range
| Variable ip> \ end of trace trap range
| Variable 'ip \ holds IP (preincrement!)
| Variable nest? \ True if NEST shall be performed
| Variable newnext \ Address of new Next for tracing
| Variable #spaces \ for indenting nested trace
| Variable tracing \ true if trace mode active
\ *** Block No. 9 Hexblock 9
\ install Tracer UH 18Nov87
Tools definitions
| Code do-trace \ patch Next to new definition
$C3 A mvi ( jmp ) >next sta
newnext lhld >next 1+ shld Next
end-code
\ *** Block No. 10 Hexblock A
\ throw status on Return-Stack 29Jun86
| Create: npull
rp@ count 2dup + even rp! r> swap cmove ;
: npush ( addr len --) r> -rot over >r
rp@ over 1+ - even dup rp! place npull >r >r ;
| : oneline .status space query interpret -&82 allot
rdrop ( delete quit from tracenext ) ;
\ *** Block No. 11 Hexblock B
\ reenter tracer 04Nov86
| Code (step
true H lxi tracing shld IP rpop Wsave lhld H W mvx
Label fnext
xchg
M E mov H inx M D mov xchg pchl
end-code
| Create: nextstep (step ;
| : (debug ( addr --) \ start tracing at addr
dup <ip !
BEGIN 1+ dup @ ['] unnest = UNTIL 2+ ip> ! ;
\ *** Block No. 12 Hexblock C
\ check trace conditions 04Nov86
Label tracenext tracenext newnext !
IP ldax IP inx A L mov IP ldax IP inx A H mov
xchg tracing lhld H A mov L ora fnext jz
nest? 1+ lda A ana
0= ?[
<IP lhld H inx
IP A mov H cmp fnext jc
0= ?[ IP' A mov L cmp fnext jc ]?
IP> lhld
H A mov IP cmp fnext jc
0= ?[ L A mov IP' cmp fnext jc ]?
][ A xra nest? 1+ sta ]? \ low byte still set
\ one trace condition satisfied
W H mvx Wsave shld false H lxi tracing shld
\ *** Block No. 13 Hexblock D
\ tracer display UH 25Jan88
;c: nest? @
IF nest? off r> ip> push <ip push dup 2- (debug
#spaces push 1 #spaces +! >r THEN
r@ nextstep >r input push output push standardi/o
cr #spaces @ spaces
dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces
>name .name $1C col - 0 max spaces .s
state push blk push >in push ['] 'quit >body push
[ ' parser >body ] Literal push
span push #tib push tib #tib @ npush r0 push
rp@ r0 ! &82 allot ['] oneline Is 'quit quit ;
\ *** Block No. 14 Hexblock E
\ DEBUG with errorchecking 28Nov86
| : traceable ( cfa -- cfa' )
recursive dup @
['] : @ case? ?exit
['] key @ case? IF >body c@ Input @ + @ traceable exit THEN
['] type @ case? IF >body c@ Output @ + @ traceable exit THEN
['] r/w @ case? IF >body traceable exit THEN
dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN
drop >name .name ." can't be DEBUGged" quit ;
also Forth definitions
: debug ( -- ) \ reads a word
' traceable (debug Tools
nest? off #spaces off tracing on do-trace ;
\ *** Block No. 15 Hexblock F
\ misc. words for tracing 28Nov86
Tools definitions
: nest \ trace next high-level word executed
'ip @ 2- @ traceable drop nest? on ;
: unnest \ ends tracing of actual word
<ip on ip> off ; \ clears trap range
: endloop \ stop tracing loop
'ip @ <ip ! ; \ use when at end of loop
Forth definitions
: trace' ( -- ) \ reads a word
context push debug <ip perform end-trace ;
\ *** Block No. 16 Hexblock 10
\ 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. 17 Hexblock 11
\ ?
: ? ( a-addr -- )
\ Display the value stored at a-addr.
@ . ;