needs lib/str lib/wordtbl lib/fmt lib/bit mem/dict
unit asm/m68kd

4 const MNEMONICSZ \ length of a mnemonic
40 const DECODEDSZ \ number of characters before spitting raw memory content
8 const DEFSZ      \ value for forcedsz which indicates the use of algorithm

16 value listingsz   \ number of lines in a listing
0 value dpc          \ disassembler program counter
0 value opcode       \ base opcode currently being decoded
DEFSZ value forcedsz \ forced size for manual decoding, room is left for floats
0 value oppc         \ opcode's pc, mainly used for .label
0 value extword      \ brief or full extension word


: op$ DEFSZ to forcedsz dpc to oppc ;

: opfield ( mask rshift ) here# rot> , , does> ( 'does )
  opcode over @ rshift swap 4+ @ and ;
: exfield ( mask rshift ) here# rot> , , does> ( 'does )
  extword over @ rshift swap 4+ @ and ;

\ Single Effective Address decoding
$f 12 opfield Sopid  \ we can distinguish instructions by their highest nibble
$7  3 opfield Smode  \ effective address mode
$7  0 opfield Sreg   \ effective address register
$3f 0 opfield Sea    \ effective address
$7  9 opfield Sreg2  \ register for words which have 2 operands
$3  6 opfield Ssz    \ regular size (e.g. arithmetic instructions)
$f  8 opfield Scond  \ condition for Scc, DBcc, and Bcc
$1  8 opfield Smisc  \ used for: distinguishing instrs, sz for *A variants, etc.

\ Brief Extension Word decoding
$1 15 exfield Bmode  \ is it Dn or An?
$7 12 exfield Breg   \ register
$1 11 exfield Bsz    \ 0 word, 1 long
$3  9 exfield Bscale \ scale applied to register
$ff 0 exfield Bdisp  \ displacement

: dpc2@+ doto dpc dup 2+ | wbe@ ;
: dpc4@+ doto dpc dup 4+ | be@ ;
: _bitgrp ( mask shift -- n )
  opcode swap rshift and ; \ just like opfield but on the fly

\ Some instructions only accept -(An) or Dn, mangle opcode to make EA work well
: bit4>mode doto opcode dup $8 and 2 lshift swap $8 invand or | ;
: regdst>src doto opcode $7 invand Sreg2 or | ;
: forcemode ( mode -- ) $7 and 3 lshift doto opcode $38 invand or | ;
: _0>8 ( n -- n ) dup 0 = if drop 8 then ;

\ 0 for 8-bit, 1 for 16-bit, 2 for 32-bit, 3 when N/A, >= DEFSZ is invalid
\ general algorithm which works for *most* opcodes, not all
: opsz ( -- n ) forcedsz DEFSZ < if forcedsz exit then Sopid case
    $0 = of Ssz endof
    $1 = of 0 endof \ move handling
    $2 = of 2 endof \ move handling
    $3 = of 1 endof \ move handling
    $4 = of Ssz endof
    $9 < of Ssz endof
    $e < of Ssz 3 = if Smisc 1+ else Ssz then endof
    $e = of Ssz 3 = if 1 else Ssz then endof
    drop endcase ;

create _ ,"bwl "
: .sz opsz _ + 1 rtype spc> ;
: .mnemonic ( a -- ) MNEMONICSZ rtype spc> ;
: .opnametbl ( idx tbl -- ) swap MNEMONICSZ * + .sz .mnemonic ;
: ., ."," ; : .$ ."$" ; : .# ."#" ; : .sr ."%sr" ; : .ccr ."%ccr" ;
: .dN1 ."%d" Sreg . ; : .aN1 ."%a" Sreg . ;
: .dN2 ."%d" Sreg2 . ; : .aN2 ."%a" Sreg2 . ;
: .unknown 3 to forcedsz .sz ."???? " ;

create _ ,"t f hilscccsneeqvcvsplmigeltgtle"
: .cond Scond 2* _ + 2 rtype ;

4 wordrefs _ dpc2@+ dpc2@+ dpc4@+ noop
: imm@ ( -- n ) _ opsz wexec ;
4 wordrefs _ .x1 .x2 .x drop
: .imm .$ imm@ _ opsz wexec ;
: .entry ( e -- ) ."`" entryname[] rtype ;
: .absw ( -- ) dpc2@+ dup ?var>e ?dup if nip .entry else .x2 .":w" then ;
: .absl ( -- ) dpc4@+ dup ?var>e ?dup if nip .entry else .x .":l" then ;
: .pc ."%pc@(" dpc2@+ sex16 . .")" ;
: .label ( n -- ) 2+ oppc + dup ?xt>e ?dup if nip .entry else .x .":l" then ;

create _ ,"dawl"
: .bxN ."%" Bmode _ + 1 rtype Breg . .":" Bsz 2+ _ + 1 rtype ;
: .bext ( pc? -- ) dpc2@+ to extword if ."%pc" else .aN1 then
  ."@(" .bxN ."*" Bscale 1 swap lshift . Bdisp sex8 dup 0>= if ."+" then . .")" ;
: .pcext 1 .bext ;

5 wordrefs _mode7 .absw .absl .pc .pcext .imm
: .ea ( -- ) Smode case
    0 = of .dN1 endof
    1 = of .aN1 endof
    6 < of r@ 4 = if ."-" then .aN1 ."@"
      r@ 3 = if ."+" then r@ 5 = if dpc2@+ ."(" sex16 . .")" then endof
    6 = of 0 .bext endof
    7 = of _mode7 Sreg wexec endof
  drop endcase ;
\ if ea is immediate, print the decimal version
: .#ea Sea $3c = if .# imm@ opsz 1 = if sex16 then . else .ea then ;

\ Direction property shared by add, sub, or, and and
: .miscdir ( -- ) Smisc if .dN2 ., .ea else .ea ., .dN2 then ;

\ ===== Instructions are decoded according to Sopid ===== /

create _ ,"ori andisubiaddi     cmpi"
create _bits ,"btstbsetbclrbchg"
: .cmp2 $3 9 _bitgrp to forcedsz .sz ."cmp2" dpc2@+ .ea .,
  dup 15 bit? if ".%a" else ."%d" then 12 rshift $7 and . ;
:~ Smisc 2* to forcedsz $3 6 _bitgrp _bits .opnametbl ;
: grp0
  Ssz 3 = Smisc 0 = and if .cmp2 exit then
  Smisc if
    Smode 1 = if opcode 6 bit? to forcedsz .sz ."movp " $5 forcemode
      opcode 7 bit? if .dN2 ., .ea else .ea ., .dN2 then
    else ~ dpc2@+ .# . ., .ea then
  else $7 9 _bitgrp dup $4 = if drop ~ .dN2 ., .ea
    else _ .opnametbl .imm .,
    Sea $3c = if opsz 0 = if .ccr else .sr then else .ea then then then ;

: eadst>src doto opcode $3f invand
  dup 9 rshift $7 and or dup 3 rshift $38 and or | ;
: .move .sz ."mov" $7 6 _bitgrp 1 = if ."a" else ."e" then spc>
  .ea ., eadst>src .ea ;

\ group 4 is huge, we group opcodes with their second highest nibble
: b8:b $f 8 _bitgrp ;
create _ ,"negxclr neg not "
create _fsz map< c, 1 0 1
: _40to6 Ssz 3 <> if b8:b 2/ _ .opnametbl .ea
  else b8:b 3 / _fsz + c@ to forcedsz .sz
    ."move " b8:b case
      0 = of .sr ., .ea endof
      4 = of .ea ., .ccr endof
      6 = of .ea ., .sr endof
    drop .unknown endcase then ;

create _ ,"ext nbcdswappea"
: _48 Smode 0 =
  if Ssz 1 = if 2 else 6 bit? 1+ to forcedsz 0 then
  else Ssz 0 = if 1 else 2 to forcedsz 3 then then _ .opnametbl .ea ;

create _ ,"ilgltas tst "
: _4a
  opcode $4afc = if 3 to forcedsz 0
    else Ssz 3 =  if 0 to forcedsz 1 else 2 then then _ .opnametbl
  opcode $4afc <> if .ea then ;

: dA<>dB ( u -- f ) dup $7 and swap 12 rshift $7 and <> ;
wordtbl[ ( u -- )
:> dup 10 bit? if ."%d" $7 and . ."-" else drop then ;
:> dup dA<>dB if ."%d" $7 and . .":" else drop then ;
]wordtbl _.dr/dq

create _ ,"divudivsmulumulsdvludvlsmulumuls"
: .divmul 2 to forcedsz
  dpc2@+ r! 11 bit? opcode 6 bit? not 2* or r@ dA<>dB r@ 10 bit? not and 4* or
  _ .opnametbl .#ea ., opcode 6 bit? r@ _.dr/dq rot wexec
  ."%d" r> 12 rshift $7 and . ;

create _ ,"rsetnop stoprte rtd rts trpvrtr "
: _4e7 3 to forcedsz Sreg _ .opnametbl
  opcode dup $4e72 = swap $4e74 = or if 1 to forcedsz .imm then ;

: .usp ."%usp" ; :~ opcode 3 bit? ;
create _ ,"linkunlk"
wordtbl[
:> 3 to forcedsz .sz ."trap " .$ opcode $f and .x2 ;
:> ~ if 3 to forcedsz then ~ _ .opnametbl .aN1 ~ not if ., .# imm@ sex16 . then ;
:> 2 to forcedsz .sz ."move " ~ if .usp ., .aN1 else .aN1 ., .usp then ;
]wordtbl _
: _4ex _ $3 4 _bitgrp wexec ;

create _ ,"jsr jmp "
create _okmodes map< c, 2 5 6 7
: .jsrjmp Smode _okmodes 4 cidx not if .unknown exit then drop
  3 to forcedsz Smisc _ .opnametbl .ea ;

create _ ,"lea chk extb"
: _4odd Smisc if
    Smode 0 = if 2 to forcedsz 2 _ .opnametbl .dN1 exit then
    Smode _okmodes 4 cidx not if .unknown exit then drop
    2 to forcedsz 0 _ .opnametbl .ea ., .aN2
    else 1 to forcedsz 1 _ .opnametbl .ea ., .dN2 then ;

: grp4
  Smode $1 = Sea $3c = or if .unknown exit then \ TODO: Consider TRAP
  b8:b case
    $1 and of _4odd endof
    $7 < of _40to6 endof
    $8 = of _48 endof
    $c = of .divmul endof
    $a = of _4a endof
    $e = of opcode 7 bit? if .jsrjmp
      else $7 4 _bitgrp $7 = if _4e7 else _4ex then then endof
  drop .unknown endcase ;

create _ ,"addqsubq"
: grp5 Ssz 3 <> if
  Smisc _ .opnametbl Sreg2 _0>8 .# . ., .ea
  else Smode 1 = if 1 to forcedsz .sz
    ."db" .cond spc> 0 forcemode .ea ., imm@ sex16 .label
    else 0 to forcedsz .sz ."s" .cond ."  " .ea then then ;

: disp@ ( -- n ) opcode $ff and case
    $00 = of 1 to forcedsz imm@ sex16 endof
    $ff = of 2 to forcedsz imm@ endof
    ( imm8 ) 0 to forcedsz sex8 endcase ;
stringlist _ bra bsr b
: grp6 disp@ .sz Scond 2 min _ slistiter stype
  Scond 1 > if .cond then ."  " .label ;

: .movq Smisc if .unknown exit then 2 to forcedsz
  .sz ."movq " opcode $ff and .# sex8 . ., .dN2 ;

create _ ,"divudivssbcdor  "
: grp8 Ssz 3 =
  if Smode 1 = if .unknown exit then
    1 to forcedsz Smisc _ .opnametbl .ea ., .dN2
  else Smode 1 = if
     0 to forcedsz 2 _ .opnametbl bit4>mode .ea ., regdst>src .ea
    else 3 _ .opnametbl .miscdir then then ;

create _ ,"subadd" \ sub and add are basically the same
: grp9d .sz opcode 14 bit? 3 * _ + 3 rtype
  Smisc $3 4 _bitgrp 0 = and if
    ."x " bit4>mode .#ea ., regdst>src .ea
  else Ssz 3 = if ."a " .#ea ., .aN2 else ."  " .miscdir then then ;

alias .unknown grpa

: grpb .sz Smisc Ssz 3 <> and if
    Smode 1 = if ."cmpm " $3 forcemode .ea ., regdst>src .ea
              else ."eor  " .dN2 ., .ea then
  else
    Ssz 3 = if ."cmpa " .#ea ., .aN2
            else ."cmp  " .#ea ., .dN2 then
  then ;

create _ ,"mulumulsabcdexg and "
3 wordrefs _reg1 .dN1 .aN1 .dN1
3 wordrefs _reg2 .dN2 .aN2 .aN2
: grpc Ssz case
  $0 = of 0 to forcedsz 2 _ .opnametbl bit4>mode .ea ., regdst>src .ea endof
  $3 = of 1 to forcedsz Smisc _ .opnametbl .ea ., .dN2 endof
  drop Smode 1 = Smode 0 = Smisc and or if ( exg )
    2 to forcedsz 3 _ .opnametbl Ssz 2* opcode 3 bit? or
    2- 2 min dup _reg2 swap wexec ., _reg1 swap wexec
  else ( and ) 4 _ .opnametbl .miscdir then
  endcase ;

stringlist _ as ls rox ro
: .dir Smisc if ."l" else ."r" then ;
:~ ( n -- ) dup .sz _ slistiter stype .dir 1 swap 2 <> if 1+ then nspcs ;
: .shift Ssz 3 = if 1 to forcedsz Sreg2 ~ .ea else
  Smode $3 and ~ opcode 5 bit? if .dN2 else Sreg2 _0>8 .# . then ., .dN1 then ;

alias .unknown grpf

16 wordrefs grps
  grp0 .move .move .move grp4 grp5 grp6 .movq
  grp8 grp9d grpa grpb grpc grp9d .shift grpf

: wbe@+ bi 2+ | wbe@ ;
\ "11 min" is there because M68000 specifies that some instructions have as many
\ as 11 words. This avoids the output from going rogue when things go wrong
: spitwords ( a u -- ) oppc dpc over - 2/ 11 min 0 do wbe@+ .x2 spc> loop drop ;
\ only the decoded part, is its own word for testing purposes
: .stem ( -- ) op$ dpc2@+ to opcode grps Sopid wexec ;
:~ dpc .x spc> .stem ;
: .op ( -- ) DECODEDSZ ['] ~ capture rtypeleft oover min spitwords nl> ;
: dis ( a -- ) to dpc listingsz 0 do .op loop ;
: dis1 ( a -- ) to dpc .op ;
: disn ( -- ) dpc dis ;