mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-05-29 02:41:32 +00:00
307 lines
19 KiB
Forth
307 lines
19 KiB
Forth
\ *** Block No. 0 Hexblock 0
|
|
\\ Z80-Disassembler 08Nov86
|
|
|
|
Dieses File enthaelt einen Z80-Disassembler, der assemblierten
|
|
Code in Standard Zilog-Z80 Mnemonics umsetzt.
|
|
|
|
Benutzung:
|
|
|
|
TOOLS ALSO \ Schalte Disassembler-Vokabular an
|
|
|
|
addr DIS \ Disassembliere ab Adresse addr
|
|
|
|
xxxx displace ! \ Beruecksichte bei allen Adressen einen
|
|
\ Versatz von xxxx.
|
|
\ Wird gebraucht, wenn ein Assemblerstueck
|
|
\ nicht an dem Platz disassembliert wird,
|
|
\ an dem es ablaeuft.
|
|
\ *** Block No. 1 Hexblock 1
|
|
\ Z80-Disassembler Load Screen 08Nov86
|
|
|
|
Onlyforth Tools also definitions hex
|
|
|
|
' Forth | Alias F: immediate
|
|
' Tools | Alias T: immediate
|
|
|
|
1 $10 +THRU cr .( Disassembler geladen. ) cr
|
|
|
|
OnlyForth
|
|
|
|
|
|
\\ Fragen Anregungen & Kritik an:
|
|
U. Hoffmann
|
|
Harmsstrasse 71
|
|
2300 Kiel 1
|
|
\ *** Block No. 2 Hexblock 2
|
|
\ Speicherzugriff und Ausgabe 07Jul86
|
|
internal
|
|
\needs Case: : Case: Create: Does> swap 2* + perform ;
|
|
|
|
Variable index Variable address Variable offset
|
|
Variable oldoutput
|
|
external Variable displace displace off internal
|
|
|
|
' pad Alias str1 ( -- addr )
|
|
: str2 ( -- addr ) str1 $40 + ;
|
|
|
|
: byte ( -- b ) address @ displace @ + c@ ;
|
|
: word ( -- w ) address @ displace @ + @ ;
|
|
|
|
: .byte ( byte -- ) 0 <# # #s #> type ;
|
|
: .word ( addr -- ) 0 <# # # # #s #> type ;
|
|
\ *** Block No. 3 Hexblock 3
|
|
\ neue Bytes lesen Byte-Fraktionen 07Jul86
|
|
|
|
: next-byte output push oldoutput @ output !
|
|
byte .byte space 1 address +! ;
|
|
|
|
: next-word next-byte next-byte ;
|
|
|
|
: f ( -- b ) byte $40 / ;
|
|
: g ( -- b ) byte 8 / 7 and ;
|
|
: h ( -- b ) byte 7 and ;
|
|
: j ( -- b ) g 2/ ;
|
|
: k ( -- b ) g 1 and ;
|
|
|
|
\\ 76543210
|
|
ffggghhh
|
|
jjk
|
|
\ *** Block No. 4 Hexblock 4
|
|
\ Select" 08Nov86
|
|
|
|
: scan/ ( limit start -- limit start' ) over swap
|
|
DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ;
|
|
|
|
: select ( n addr len -- addr' len' )
|
|
bounds rot
|
|
0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN
|
|
LOOP under scan/ nip over - ;
|
|
|
|
: (select" ( n -- ) "lit count select type ;
|
|
|
|
: select" ( -- ) compile (select" ," ; immediate
|
|
|
|
: append ( c str -- )
|
|
under count + c! dup c@ 1+ swap c! ;
|
|
\ *** Block No. 5 Hexblock 5
|
|
\ StringOutput 07Jul86
|
|
|
|
Variable $
|
|
|
|
: $emit ( c -- ) $ @ append pause ;
|
|
|
|
: $type ( adr len -- ) 0 ?DO count $emit LOOP drop ;
|
|
|
|
: $cr ( -- ) $ @ off ;
|
|
|
|
: $at? ( -- row col ) 0 $ @ c@ ;
|
|
|
|
Output: $output
|
|
$emit $cr $type noop $cr 2drop $at? ;
|
|
|
|
|
|
\ *** Block No. 6 Hexblock 6
|
|
\ Register 07Jul86
|
|
|
|
: reg ( n -- ) dup 5 = IF index @ negate index ! THEN
|
|
select" B/C/D/E/H/L/$/A" ;
|
|
|
|
: double-reg ( n -- ) select" BC/DE/%/SP" ;
|
|
|
|
: double-reg2 ( n -- ) select" BC/DE/%/AF" ;
|
|
|
|
: num ( n -- ) select" 0/1/2/3/4/5/6/7" ;
|
|
|
|
: cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ;
|
|
|
|
: arith ( n -- )
|
|
select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ;
|
|
|
|
\ *** Block No. 7 Hexblock 7
|
|
\ no-prefix Einteilung der Befehle in Klassen 07Jul86
|
|
|
|
: 00xxx000
|
|
g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN
|
|
select" nop/ex AF,AF'/djnz ?/jr ?" ;
|
|
|
|
: 00xxx001
|
|
k IF ." add %," j double-reg exit THEN
|
|
." ld " j double-reg ." ,&" ;
|
|
|
|
: 00xxx010 ." ld " g
|
|
select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)"
|
|
;
|
|
|
|
: 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ;
|
|
|
|
\ *** Block No. 8 Hexblock 8
|
|
\ no-prefix 07Jul86
|
|
|
|
: 00xxx100 ." inc " g reg ;
|
|
|
|
: 00xxx101 ." dec " g reg ;
|
|
|
|
: 00xxx110 ." ld " g reg ." ,#" ;
|
|
|
|
: 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ;
|
|
|
|
: 01xxxxxx ." ld " g reg ." ," h reg ;
|
|
|
|
: 10xxxxxx g arith h reg ;
|
|
|
|
|
|
|
|
\ *** Block No. 9 Hexblock 9
|
|
\ no-prefix 07Jul86
|
|
|
|
: 11xxx000 ." ret " g cond ;
|
|
|
|
: 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN
|
|
." pop " j double-reg2 ;
|
|
|
|
: 11xxx010 ." JP " g cond ." ,&" ;
|
|
|
|
: 11xxx011 g
|
|
select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ;
|
|
|
|
: 11xxx100 ." call " g cond ;
|
|
: 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ;
|
|
: 11xxx110 g arith ." #" ;
|
|
: 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ;
|
|
\ *** Block No. 10 Hexblock A
|
|
\ no-prefix 07Jul86
|
|
|
|
Case: 00xxxhhh
|
|
00xxx000 00xxx001 00xxx010 00xxx011
|
|
00xxx100 00xxx101 00xxx110 00xxx111 ;
|
|
|
|
Case: 11xxxhhh
|
|
11xxx000 11xxx001 11xxx010 11xxx011
|
|
11xxx100 11xxx101 11xxx110 11xxx111 ;
|
|
|
|
: 00xxxxxx h 00xxxhhh ;
|
|
: 11xxxxxx h 11xxxhhh ;
|
|
|
|
Case: ffxxxxxx
|
|
00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ;
|
|
|
|
\ *** Block No. 11 Hexblock B
|
|
\ no-prefix 07Jul86
|
|
|
|
: get-offset index @ 0> IF byte offset ! next-byte THEN ;
|
|
|
|
: no-prefix f ffxxxxxx next-byte get-offset ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 12 Hexblock C
|
|
\ CB-Prefix 07Jul86
|
|
|
|
: CB-00xxxxxx
|
|
g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ;
|
|
|
|
: CB-01xxxxxx ." bit " g num ." ," h reg ;
|
|
|
|
: CB-10xxxxxx ." res " g num ." ," h reg ;
|
|
|
|
: CB-11xxxxxx ." set " g num ." ," h reg ;
|
|
|
|
case: singlebit
|
|
CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ;
|
|
|
|
: CB-prefix get-offset f singlebit next-byte ;
|
|
|
|
\ *** Block No. 13 Hexblock D
|
|
\ ED-Prefix 30Sep86
|
|
: ED-01xxx000 ." in (C)," g reg ;
|
|
: ED-01xxx001 ." out (C)," g reg ;
|
|
: ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN
|
|
." HL," j double-reg ;
|
|
: ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN
|
|
." (&)," j double-reg ;
|
|
: ED-01xxx100 ." neg" ;
|
|
: ED-01xxx101 k IF ." reti" exit THEN ." retn" ;
|
|
: ED-01xxx110 g select" im 0/-/im 1/im 2" ;
|
|
: ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ;
|
|
: ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ;
|
|
Case: ED-01xxxhhh
|
|
ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011
|
|
ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ;
|
|
: ED-01xxxxxx h ED-01xxxhhh ;
|
|
\ *** Block No. 14 Hexblock E
|
|
\ ED-Prefix 07Jul86
|
|
|
|
Case: extended
|
|
noop ED-01xxxxxx ED-10xxxxxx noop ;
|
|
|
|
: ED-prefix get-offset f extended next-byte ;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 15 Hexblock F
|
|
\ Disassassemblieren eines einzelnen Befehls 30Sep86
|
|
|
|
: index-register ( n -- ) index ! next-byte ;
|
|
|
|
: get-instruction ( -- )
|
|
index off str1 $ ! cr
|
|
byte $DD = IF 1 index-register ELSE
|
|
byte $FD = IF 2 index-register THEN THEN
|
|
byte $76 case? IF next-byte ." halt" exit THEN
|
|
$CB case? IF next-byte CB-prefix exit THEN
|
|
$ED case? IF next-byte ED-prefix exit THEN
|
|
drop no-prefix ;
|
|
|
|
|
|
|
|
|
|
\ *** Block No. 16 Hexblock 10
|
|
\ Adressierungsarten ausgeben 07Jul86 27Nov87
|
|
: .index-register ( -- ) index @ abs select" HL/IX/IY" ;
|
|
|
|
: offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ;
|
|
: +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ;
|
|
|
|
: .offset ( -- ) offset @ offset-sign
|
|
extend under dabs <# # #s rot +- #> type ;
|
|
: .index-register-offset
|
|
index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ;
|
|
|
|
: .inline-byte ( -- ) byte .byte next-byte ;
|
|
: .inline-word ( -- ) word .word next-word ;
|
|
|
|
: .displace ( -- )
|
|
byte offset-sign address @ + 1+ .word next-byte ;
|
|
\ *** Block No. 17 Hexblock 11
|
|
\ Hauptebene: dis 07Jul86
|
|
: .char ( c -- )
|
|
Ascii % case? IF .index-register exit THEN
|
|
Ascii $ case? IF .index-register-offset exit THEN
|
|
Ascii # case? IF .inline-byte exit THEN
|
|
Ascii & case? IF .inline-word exit THEN
|
|
Ascii ? case? IF .displace exit THEN emit ;
|
|
|
|
: instruction ( -- ) cr address @ .word 2 spaces
|
|
output @ oldoutput ! $output get-instruction
|
|
str2 $ ! cr str1 count 0 ?DO count .char LOOP drop
|
|
oldoutput @ output ! $20 col - 0 max spaces str2 count type ;
|
|
|
|
external
|
|
: dis ( addr -- ) address !
|
|
BEGIN instruction stop? UNTIL ;
|