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