# Slow but sufficient disassembler for the Wang disk controller
# read in existing listing and generate augmented listing.

@dtab = (
    # register instructions
    [ 0xF000, 0x0000, \&nop ],
    [ 0xF000, 0x1000, \&b2mem ],
    [ 0xF000, 0x2000, \&mem2b ],
    [ 0xF000, 0x3000, \&addc ],
    [ 0xF000, 0x4000, \&or ],
    [ 0xF000, 0x5000, \&xor ],
    [ 0xF000, 0x6000, \&add ],
    [ 0xF000, 0x7000, \&and ],

    # immediate instructions
    [ 0xFC00, 0xC800, \&or_imm ],
    [ 0xFC00, 0xD800, \&xor_imm ],
    [ 0xFC00, 0xE800, \&add_imm ],
    [ 0xFC00, 0xF800, \&and_imm ],

    # branch instructions
    [ 0xFC00, 0xCC00, \&bez ],
    [ 0xFC00, 0xDC00, \&bnz ],

    # mask branch instructions
    [ 0xF800, 0xA000, \&bt ],
    [ 0xF800, 0xB000, \&bf ],
    [ 0xF800, 0x8000, \&bmeq ],
    [ 0xF800, 0x9000, \&bmne ],

    # unconditional branch instruction
    [ 0xFC00, 0x8800, \&ub ],

    # load ram address
    [ 0xFE00, 0x8C00, \&la ],

    # control instructions
    [ 0xFC00, 0xEC00, \&ctl1 ],
    [ 0xFC00, 0xFC00, \&ctl2 ],
);


# =============================================================
#   main
# =============================================================

@listing = ();
@targets = ();

open(INFILE, "ucode.txt") || die "couldn't open file: $!";

while(<INFILE>) {
    if (/^\s*;/) {
	push @listing, [ -1, $_ ];	# just echo comment lines
	next;
    }
    if (/^([0-9A-F]{4}?)\s+([0-9A-F]{4}?)(\s+(.+)$)?/) {
	my($newline) = &dasm($1, $2, $4);
	push @listing, [ hex($1), $newline ];
	next;
    }
    print "Error on line $.: unrecognized format\n";
    print $_;
    die;
}

foreach my $line (@listing) {

    $thisaddr = $line->[0];
    $thisline = $line->[1];

    # a mark of 1 means a 4b page branch to this address
    # a mark of 2 means an 8b page branch to this address
    # a mark of 4 means a unconditional 10b branch to this address
    # they can be OR'd together
    if ($thisaddr <= 0 || $target[$thisaddr] == 0) {
	$mark = " ";
    } else {
	$mark = $target[$thisaddr];
    }
    print "$mark $thisline";
}

# =============================================================

sub set_target {
    my($addr, $type) = @_;
    $target[$addr] |= $type;
}


sub dasm {
    my ($addr, $ucode, $comment) = @_;
    my ($bc) = hex($ucode);
    my ($mask,$val,$dsub);
    my ($found) = 0;
    my ($newdasm, $line);

    #print "$addr:$ucode -- $comment\n";
    if (1 == 1) {
	# remove old opcode, but keep comment
	$comment = substr($comment, 20);
    }

    foreach my $op (@dtab) {
	($mask,$val,$dsub) = @{$op};
        # print "mask is $mask, val is $val, sub is $dsub\n";
        # printf "testing (0x%04X & 0x%04X) == 0x%04x =? 0x%04X\n",
        #         $bc, $mask, ($bc&$mask), $val;
	if (($bc & $mask) == $val) {
	    $newdasm = &{$dsub}($bc, hex($addr));
	    $found = 1;
	    next;
	}
    }
    if ($found) {
	$line = sprintf("$addr [ %-18s ] -- $comment\n", $newdasm);
    } else {
	$line = "ERROR: couldn't translate 0x$ucode at 0x$addr\n";
    }
    return $line;
}

sub dasm_reg {
    my($ucode) = shift;
    my(@decode) = ( "A", "K", "ST0", "ST1" );
    my($field) = ($ucode >> 8) & 3;
    return $decode[$field];
}

sub dasm_id {
    my($ucode) = shift;
    my($field) = ($ucode >> 10) & 3;
    my(@decode) = ( "M(N)", "M(+1)", "M(-1)", "M(+1)RTB" );
    return $decode[$field];
}

sub nop {
    my($ucode) = shift;
    my($field) = ($ucode >> 10) & 3;
    my(@decode) = ( "", "(+1)", "(-1)", "(+1)" );
    return "NOOP " . $decode[$field];
}

sub b2mem {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " TO " . &dasm_id($ucode);
}

sub mem2b {
    my($ucode) = shift;
    return &dasm_id($ucode). " TO " . &dasm_reg($ucode);
}

sub addc {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " ADC " . &dasm_id($ucode);
}

sub or {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " OR " . &dasm_id($ucode);
}

sub xor {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " XOR " . &dasm_id($ucode);
}

sub add {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " ADD " . &dasm_id($ucode);
}

sub and {
    my($ucode) = shift;
    return &dasm_reg($ucode) . " AND " . &dasm_id($ucode);
}

sub or_imm {
    my($ucode) = shift;
    my($imm) = ($ucode & 0xFF);
    return &dasm_reg($ucode) . " OR " . sprintf("#%02X", $imm);
}

sub xor_imm {
    my($ucode) = shift;
    my($imm) = ($ucode & 0xFF);
    return &dasm_reg($ucode) . " XOR " . sprintf("#%02X", $imm);
}

sub add_imm {
    my($ucode) = shift;
    my($imm) = ($ucode & 0xFF);
    return &dasm_reg($ucode) . " ADD " . sprintf("#%02X", $imm);
}

sub and_imm {
    my($ucode) = shift;
    my($imm) = ($ucode & 0xFF);
    return &dasm_reg($ucode) . " AND " . sprintf("#%02X", $imm);
}

sub bez {
    my($ucode,$addr) = @_;
    my($newaddr) = ($addr & 0xF00) | ($ucode & 0x0FF);
    &set_target($newaddr, 2);
    return "IF " . &dasm_reg($ucode) . "==0 GO " . sprintf("#%03X", $newaddr);
}

sub bnz {
    my($ucode,$addr) = @_;
    my($newaddr) = ($addr & 0xF00) | ($ucode & 0x0FF);
    &set_target($newaddr, 2);
    return "IF " . &dasm_reg($ucode) . "<>0 GO " . sprintf("#%03X", $newaddr);
}

sub bt {
    my($ucode,$addr) = @_;
    my(@bdec) = ("BT A", "BT K", "BT S0", "BT S1");
    my($mfield) = ($ucode >>  4) & 0xF;
    my($bfield) = ($ucode >>  8) & 3;
    my($sfield) = ($ucode >> 10) & 1;
    my($newaddr) = ($addr & 0xFF0) | ($ucode & 0x00F);
    my($mask8) = $sfield ? ($mfield << 4) : $mfield;
    &set_target($newaddr, 1);
    return $bdec[$bfield] . sprintf(" & #%02X GO %03X", $mask8, $newaddr);
}

sub bf {
    my($ucode,$addr) = @_;
    my(@bdec) = ("BF A", "BF K", "BF S0", "BF S1");
    my($mfield) = ($ucode >>  4) & 0xF;
    my($bfield) = ($ucode >>  8) & 3;
    my($sfield) = ($ucode >> 10) & 1;
    my($newaddr) = ($addr & 0xFF0) | ($ucode & 0x00F);
    $mfield = (~$mfield) & 0xF;
    $mask8 = $sfield ? ($mfield << 4) : $mfield;
    &set_target($newaddr, 1);
    return $bdec[$bfield] . sprintf(" & #%02X GO %03X", $mask8, $newaddr);
}

sub bmeq {
    my($ucode,$addr) = @_;
    my(@bdec) = ("IF A", "IF K", "IF S0", "IF S1");
    my(@sdec) = ("L", "H");
    my($mfield) = ($ucode >>  4) & 0xF;
    my($bfield) = ($ucode >>  8) & 3;
    my($sfield) = ($ucode >> 10) & 1;
    my($newaddr) = ($addr & 0xFF0) | ($ucode & 0x00F);
    &set_target($newaddr, 1);
    return $bdec[$bfield] . $sdec[$sfield] . sprintf("==#%X GO %03X", $mfield, $newaddr);
}

sub bmne {
    my($ucode,$addr) = @_;
    my(@bdec) = ("IF A", "IF K", "IF S0", "IF S1");
    my(@sdec) = ("L", "H");
    my($mfield) = ($ucode >>  4) & 0xF;
    my($bfield) = ($ucode >>  8) & 3;
    my($sfield) = ($ucode >> 10) & 1;
    my($newaddr) = ($addr & 0xFF0) | ($ucode & 0x00F);
    &set_target($newaddr, 1);
    return $bdec[$bfield] . $sdec[$sfield] . sprintf("<>#%X GO %03X", $mfield, $newaddr);
}

sub ub {
    my($ucode) = shift;
    my($newaddr) = ($ucode & 0x3FF);
    &set_target($newaddr, 4);
    return sprintf("GO #%03X",$newaddr);
}

sub la {
    my($ucode) = shift;
    my($imm) = ($ucode & 0x1FF);
    return sprintf("LA #%03X", $imm);
}

sub ctl1 {
    my($ucode) = shift;
    return sprintf("CTL1 #%03X", ($ucode & 0x3FF));
}

sub ctl2 {
    my($ucode) = shift;
    return sprintf("CTL2 #%03X", ($ucode & 0x3FF));
}