libs/zxdisasm.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Z80 Disassembler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 vocabulary zxdis
   8 also zxdis definitions
   9
  10 defer-not-yet peek  ( addr -- byte )
  11
  12 0 value pc
  13 true value num-hex?
  14
  15 <hidden-words>
  16 0 value (ixiy)  \ contains 0, [char] x or [char] y
  17 0 value (disp)
  18 0 value (dptr)
  19 0 value (dofs)
  20 0 value (opcode)
  21
  22
  23 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 create ixydisp-table
  25   0x00 c, 0x00 c, 0x00 c, 0x00 c,
  26   0x00 c, 0x00 c, 0x70 c, 0x00 c,
  27   0x40 c, 0x40 c, 0x40 c, 0x40 c,
  28   0x40 c, 0x40 c, 0xBF c, 0x40 c,
  29   0x40 c, 0x40 c, 0x40 c, 0x40 c,
  30   0x40 c, 0x40 c, 0x40 c, 0x40 c,
  31   0x00 c, 0x08 c, 0x00 c, 0x00 c,
  32   0x00 c, 0x00 c, 0x00 c, 0x00 c,
  33 create;
  34
  35
  36 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 : get-dis-str  ( addr count -- ) (dptr) (dofs) ; (public)
  38
  39 : put-char  ( ch -- )
  40   (dptr) (dofs) + c!
  41   1 +to (dofs)
  42 ;
  43
  44 : put-str  ( addr len -- )
  45   dup +if over + swap do i c@ put-char loop else 2drop endif
  46 ;
  47
  48 : put-space  ( -- ) bl put-char ;
  49 : put-comma  ( -- ) [char] , put-char ;
  50 : put-lpar  ( -- ) [char] ( put-char ;  ;; )
  51 : put-rpar  ( -- ) [char] ) put-char ;
  52
  53
  54 : put-str-4   ( idx addr count -- ) drop + 4 put-str ;
  55 : put-str-2x  ( addr -- ) 2 put-str ;
  56 : put-str-4x  ( addr -- ) dup 3 + c@ bl = if 3 else 4 endif put-str ;
  57
  58
  59 \ ////////////////////////////////////////////////////////////////////////// //
  60 : put-n.r  ( n r -- )
  61   base @ >r
  62   num-hex? if
  63     >r hex <#u r> for # endfor [char] # hold
  64   else
  65     drop decimal <#u #s
  66   endif
  67   #> put-str r> base !
  68 ;
  69
  70 : put-n8   ( n -- )  0xff and 2 put-n.r ;
  71 : put-n16  ( n -- )  0xffff and 4 put-n.r ;
  72
  73 : put-disp  ( -- )
  74   (disp) -if [char] - else [char] + endif put-char
  75   (disp) abs
  76   base @ >r decimal <#u #s #>
  77   put-str r> base !
  78 ;
  79
  80
  81 \ ////////////////////////////////////////////////////////////////////////// //
  82 \ advances PC
  83 : fetch-byte  ( -- b )
  84   pc peek
  85   pc 1+ 0xFFFF and to pc
  86 ;
  87
  88 \ advances PC
  89 : fetch-word  ( -- b )
  90   fetch-byte fetch-byte 8 lshift or
  91 ;
  92
  93 : byte->signed  ( b -- n )  dup 0x80 >= if 0x100 - endif ;
  94
  95
  96 \ ////////////////////////////////////////////////////////////////////////// //
  97 : put-ixy-mem ( -- )
  98   " (i" put-str
  99   (ixiy) put-char
 100   put-disp
 101   put-rpar
 102 ;
 103
 104
 105 : put-r8  ( r8 -- )
 106   7 and  " bcdehl.a" drop + c@
 107   dup [char] . = if
 108     \ (hl)
 109     drop (ixiy) if put-ixy-mem else " (hl)" put-str endif
 110   else
 111     \ undocumented IX/IY 8-bit part access
 112     (ixiy) if
 113       dup [char] h = over [char] l = or if
 114         \ [char] i put-char
 115         (ixiy) put-char
 116       endif
 117     endif
 118     put-char
 119   endif
 120 ;
 121
 122
 123 : put-r16-hl-ixy  ( -- )
 124   \ hl
 125   (ixiy) if
 126     " i" put-str
 127     (ixiy) put-char
 128   else
 129     " hl" put-str
 130   endif
 131 ;
 132
 133 : put-v16  ( -- )  fetch-word put-n16 ;
 134 : put-m16  ( -- )  put-lpar put-v16 put-rpar ;
 135
 136 : put-r16-common  ( r16 addr count -- )
 137   drop swap 3 and 2u* +
 138   dup c@ [char] h = if drop put-r16-hl-ixy else put-str-2x endif
 139 ;
 140
 141 : put-r16-sp  ( r16 -- )
 142   (opcode) 4 rshift
 143   " bcdehlsp" put-r16-common
 144 ;
 145
 146 : put-r16-af  ( r16 -- )
 147   (opcode) 4 rshift
 148   " bcdehlaf" put-r16-common
 149 ;
 150
 151
 152 : put-cc  ( cc -- )
 153   7 and 2u* " nzz ncc popep m " drop +
 154   dup c@ put-char
 155   1+ c@ dup 32 <> if put-char else drop endif
 156 ;
 157
 158
 159 \ ////////////////////////////////////////////////////////////////////////// //
 160 : decode-cb-unixy  ( -- )
 161   \ special undocumented thing
 162   (ixiy) if
 163     \ `bit` doesn't need undoc ixy
 164     (opcode) 0x80 and if
 165       (opcode) 7 and 6 <> if
 166         put-comma
 167         put-ixy-mem
 168       endif
 169     endif
 170   endif
 171 ;
 172
 173 : decode-cb  ( -- )
 174   (opcode) 0xc0 and if
 175     (opcode) 4 rshift 0x0c and 4- " bit res set " put-str-4
 176     put-space
 177     (opcode) 3 rshift 7 and [char] 0 + put-char
 178     put-comma
 179   else
 180     (opcode) 2u/ 0x1c and
 181     " rlc rrc rl  rr  sla sra sll srl " put-str-4
 182     put-space
 183   endif
 184   (opcode) put-r8
 185   decode-cb-unixy
 186 ;
 187
 188
 189 \ ////////////////////////////////////////////////////////////////////////// //
 190 : decode-ed-xrep  ( -- )
 191   \ two instructions with the wrong mnemonic length
 192   (opcode) 0xa3 = if " outi" put-str exit endif
 193   (opcode) 0xab = if " outd" put-str exit endif
 194   \ common code
 195   (opcode) 3 and 2u* " ldcpinot" drop + put-str-2x
 196   (opcode) 0x08 and if [char] d else [char] i endif put-char
 197   (opcode) 0x10 and if [char] r put-char endif
 198 ;
 199
 200 : decode-ed-spec-im  ( -- )
 201   " im   " put-str
 202   (opcode) 0x47 = if " 0/1" put-str exit endif
 203   (opcode) 0x10 and if
 204     (opcode) 0x08 and if [char] 2 else [char] 1 endif
 205   else
 206     [char] 0
 207   endif
 208   put-char
 209 ;
 210
 211 : decode-ed-spec-7  ( -- )
 212   (opcode) case
 213     0x47 of " ld   i,a" endof
 214     0x4f of " ld   r,a" endof
 215     0x57 of " ld   a,i" endof
 216     0x5f of " ld   a,r" endof
 217     0x67 of " rrd" endof
 218     0x6f of " rld" endof
 219     otherwise drop " nope"
 220   endcase
 221   put-str
 222 ;
 223
 224 : decode-ed-spec  ( -- )
 225   (opcode) 7 and case
 226     0x04 of " neg" put-str endof
 227     0x05 of " ret" put-str (opcode) 0x08 and if [char] i else [char] n endif put-char endof
 228     0x06 of decode-ed-spec-im endof
 229     0x07 of decode-ed-spec-7 endof
 230     " nope" put-str
 231   endcase
 232 ;
 233
 234 : decode-ed-spec-r16  ( -- )
 235   \ r16
 236   (opcode) 0x01 and if
 237     " ld   " put-str
 238     \ direction
 239     (opcode) 0x08 and if
 240       \ to rr
 241       put-r16-sp
 242       put-comma
 243       put-m16
 244     else
 245       \ to mem
 246       put-m16
 247       put-comma
 248       put-r16-sp
 249     endif
 250   else
 251     (opcode) 2u/ 4 and " sbc adc " put-str-4
 252     "  hl," put-str
 253     put-r16-sp
 254   endif
 255 ;
 256
 257 : decode-ed-spec-in/out  ( -- )
 258   (opcode) 0x01 and if
 259     " out  (c)," put-str
 260     (opcode) 3 rshift
 261     \ check for `(hl)`, it is special here
 262     dup 7 and 6 = if
 263       drop [char] 0 put-char
 264     else
 265       put-r8
 266     endif
 267   else
 268     " in   " put-str
 269     (opcode) 3 rshift
 270     \ check for `(hl)`, it is special here
 271     dup 7 and 6 <> if
 272       put-r8
 273       put-comma
 274     else
 275       drop
 276     endif
 277     " (c)" put-str
 278   endif
 279 ;
 280
 281
 282 : decode-ed  ( -- )
 283   (opcode) 0xa4 and 0xa0 = if decode-ed-xrep exit endif
 284   (opcode) 0xc0 and 0x40 <> if " nope" put-str exit endif
 285   (opcode) case
 286     0x04 and-of decode-ed-spec endof
 287     0x02 and-of decode-ed-spec-r16 endof
 288     decode-ed-spec-in/out
 289   endcase
 290 ;
 291
 292
 293 \ ////////////////////////////////////////////////////////////////////////// //
 294 \ ld r8,r8 (and halt)
 295 : decode-norm-grp1  ( -- )
 296   (opcode) 0x76 = if " halt" put-str exit endif
 297   " ld   " put-str
 298   (opcode) 3 rshift put-r8
 299   put-comma
 300   (opcode) put-r8
 301 ;
 302
 303 : decode-alu-name  ( -- )
 304   (opcode) 2u/ 0x1c and " add adc sub sbc and xor or  cp  " put-str-4
 305   put-space
 306   \ two special opcodes
 307   (opcode) 0x38 and dup 0x08 = over 0x18 = or swap 0x00 = or if " a," put-str endif
 308 ;
 309
 310
 311 : decode-norm-grp3-1  ( -- )
 312   (opcode) 0x08 and if
 313     (opcode) 0x30 and case
 314       0x00 of " ret" put-str endof
 315       0x10 of " exx" put-str endof
 316       0x20 of " jp   (" put-str put-r16-hl-ixy put-rpar endof
 317       0x30 of " ld   sp," put-str put-r16-hl-ixy endof
 318     endcase
 319   else
 320     " pop  " put-str
 321     put-r16-af
 322   endif
 323 ;
 324
 325 : decode-norm-grp3-3  ( -- )
 326   (opcode) 0x38 and case
 327     0x00 of " jp   " put-str put-v16 endof
 328     \ CB:0x08 of endof
 329     0x10 of " out  (" put-str fetch-byte put-n8 " ),a" put-str endof
 330     0x18 of " in   a,(" put-str fetch-byte put-n8 put-rpar endof
 331     0x20 of " ex   (sp)," put-str put-r16-hl-ixy  endof
 332     0x28 of " ex   de,hl" put-str endof
 333     0x30 of " di" put-str endof
 334     0x38 of " ei" put-str endof
 335   endcase
 336 ;
 337
 338 : decode-norm-grp3-5  ( -- )
 339   (opcode) 0x08 and if
 340     \ prefixes already done, so only call is left
 341     " call " put-str
 342     put-v16
 343   else
 344     " push " put-str
 345     put-r16-af
 346   endif
 347 ;
 348
 349 \ call,ret,push,pop,etc.
 350 : decode-norm-grp3  ( -- )
 351   (opcode) 7 and case
 352     0x00 of " ret  " put-str  (opcode) 3 rshift put-cc endof
 353     0x01 of decode-norm-grp3-1 endof
 354     0x02 of " jp   " put-str  (opcode) 3 rshift put-cc put-comma put-v16 endof
 355     0x03 of decode-norm-grp3-3 endof
 356     0x04 of " call " put-str  (opcode) 3 rshift put-cc put-comma put-v16 endof
 357     0x05 of decode-norm-grp3-5 endof
 358     0x06 of decode-alu-name fetch-byte put-n8 endof
 359     0x07 of " rst  " put-str (opcode) 0x38 and put-n8 endof
 360   endcase
 361 ;
 362
 363 : decode-norm-grp0-0-add/ld  ( -- )
 364   (opcode) 0x08 and if
 365     " add  " put-str
 366     put-r16-hl-ixy
 367     put-comma
 368     put-r16-sp
 369   else
 370     " ld   " put-str
 371     put-r16-sp
 372     put-comma
 373     put-v16
 374   endif
 375 ;
 376
 377 : decode-norm-grp0-0-jr-cc  ( -- )
 378   " jr   " put-str
 379   (opcode) 3 rshift 3 and put-cc
 380   put-comma
 381   fetch-byte dup 0x80 >= if 0x100 - endif
 382   pc + put-n16
 383 ;
 384
 385 : decode-norm-grp0-0-jr-djnz  ( -- )
 386   (opcode) 2u/ 4 and " djnzjr  " put-str-4
 387   put-space
 388   fetch-byte dup 0x80 >= if 0x100 - endif
 389   pc + put-n16
 390 ;
 391
 392 : decode-norm-grp0-0  ( -- )
 393   (opcode) 1 and if
 394     decode-norm-grp0-0-add/ld
 395   else
 396     (opcode) case
 397       0x20 and-of decode-norm-grp0-0-jr-cc endof
 398       0x10 and-of decode-norm-grp0-0-jr-djnz endof
 399       (opcode) 0x08 and if " ex   af,af'" else " nop" endif put-str
 400     endcase
 401   endif
 402 ;
 403
 404 : decode-norm-grp0-2  ( -- )
 405   (opcode) 1 and if
 406     (opcode) 2u/ 4 and " inc dec " put-str-4
 407     put-space
 408     put-r16-sp
 409   else
 410     " ld   " put-str
 411     (opcode) 0x3c and case
 412       0x00 of " (bc),a" put-str endof
 413       0x08 of " a,(bc)" put-str endof
 414       0x10 of " (de),a" put-str endof
 415       0x18 of " a,(de)" put-str endof
 416       0x20 of put-m16 put-comma put-r16-hl-ixy endof
 417       0x28 of put-r16-hl-ixy put-comma put-m16 endof
 418       0x30 of put-m16 " ,a" put-str endof
 419       0x38 of " a," put-str put-m16 endof
 420     endcase
 421   endif
 422 ;
 423
 424 : decode-norm-grp0-4  ( -- )
 425   (opcode) 0x01 and 2 lshift " inc dec " put-str-4
 426   put-space
 427   (opcode) 3 rshift put-r8
 428 ;
 429
 430 : decode-norm-grp0-6  ( -- )
 431   (opcode) 1 and if
 432     (opcode) 2u/ 0x1c and " rlcarrcarla rra daa cpl scf ccf " drop + put-str-4x
 433   else
 434     " ld   " put-str
 435     (opcode) 3 rshift put-r8
 436     put-comma
 437     fetch-byte put-n8
 438   endif
 439 ;
 440
 441 : decode-norm-grp0  ( -- )
 442   (opcode) 0x06 and case
 443     0x00 of decode-norm-grp0-0 endof
 444     0x02 of decode-norm-grp0-2 endof
 445     0x04 of decode-norm-grp0-4 endof
 446     0x06 of decode-norm-grp0-6 endof
 447   endcase
 448 ;
 449
 450 : decode-norm  ( -- )
 451   (opcode) 0xc0 and case
 452     0x00 of decode-norm-grp0 endof
 453     0x40 of decode-norm-grp1 endof
 454     0x80 of decode-alu-name (opcode) put-r8 endof \ alu a,r8
 455     decode-norm-grp3
 456   endcase
 457 ;
 458
 459
 460 \ ////////////////////////////////////////////////////////////////////////// //
 461 <public-words>
 462 ;; set "pc"; will modify "pc"
 463 : disasm-one ( -- )
 464   0 to (ixiy)
 465   pad 420 + to (dptr)
 466   0 to (dofs)
 467   0 to (disp)
 468   fetch-byte
 469
 470   \ check if I<X|Y> prefix
 471   dup 0xdd = if [char] x to (ixiy) endif
 472   dup 0xfd = if [char] y to (ixiy) endif
 473   (ixiy) if
 474     drop fetch-byte dup to (opcode)
 475     dup 0xdd = over 0xfd = or if
 476       drop " nopx" put-str
 477       \ one byte back
 478       pc 1- 0xFFFF and to pc
 479       exit
 480     endif
 481     \ check if we have disp here
 482     dup 3 rshift ixydisp-table + c@
 483     1 rot 7 and lshift and if
 484       \ has disp
 485       fetch-byte byte->signed to (disp)
 486     endif
 487   else
 488     to (opcode)
 489   endif
 490
 491   (opcode) case
 492     0xcb of fetch-byte to (opcode) decode-cb endof
 493     0xed of fetch-byte to (opcode) decode-ed endof
 494     decode-norm
 495   endcase
 496 ;
 497
 498 previous definitions