VolksForth/8080/CPM/disass.fb

\\ 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.                         \ 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                                    \ Speicherzugriff und Ausgabe                         07Jul86internal                                                        \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 ;                      \ 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                                                          \ 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! ;                           \ 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? ;                                                                                                                                                            \ 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 " ;                                                                          \ 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 ;                                                                         \ 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 ;                                                                                                                                                                                                                                         \ 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" ;             \ 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 ;                                                                                               \ no-prefix                                        07Jul86                                                                : get-offset   index @ 0> IF byte offset ! next-byte THEN ;                                                                     : no-prefix  f ffxxxxxx  next-byte  get-offset ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \ 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 ;                                                                                  \ 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 ;                                        \ ED-Prefix                                        07Jul86                                                                Case: extended                                                    noop  ED-01xxxxxx  ED-10xxxxxx noop ;                                                                                         : ED-prefix  get-offset  f extended  next-byte ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   \ 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 ;                                                                                                                                                                                                                                                                                                                \ 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 ;             \ 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 ;