mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-12-01 19:49:57 +00:00
307 lines
19 KiB
Forth
307 lines
19 KiB
Forth
|
\ *** 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.
|
||
|
|
@ . ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|