VolksForth/sources/cpm/disass.fth

307 lines
19 KiB
Forth
Raw Normal View History

\ *** 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 ;