use strict;

use warnings;

use Getopt::Long qw(:config no_ignore_case);

no warnings 'recursion';

my $verbose = 0;

sub info { $verbose and warn @_; }

my @mn;

my @mode;

my @len;

my @illegal;

sub init {

my ($illegal) = @_;

my @lines = <DATA>;

close DATA;

for (@lines) {

/(.) {3}(\w{3}) {6}\$(..) {7}(.{27})\((.*)\) *(\d)\/(.*)/ or next;

my ($std, $mn, $hex, $oper, $mode, $len, $cycles) =

($1,$2,$3,$4,$5,$6,$7);

my $code = hex($hex);

$illegal[$code] = $std eq "*" ? 0 : 1 if not $illegal;

$mn[$code] = lc $mn;

$mode[$code] = $mode;

$len[$code] = $len;

}

}

use constant {

SEGNUM => 0,

VALUE => 1,

LEN => 2,

CALLERS => 3,

ACCESSORS => 4,

TARGETS => 5,

LABEL => 6,

ADDRESS => 7,

};

sub state {

return {

mem => [map [0], 0 .. 0x10000],

segnum => 0,

};

}

sub layer {

my ($state, $start, $end, $data) = @_;

my $segnum = $state->{segnum};

length $data == $end - $start + 1 or

die "ERROR: layer size doesn't match start, end: $start, $end\n";

my @mem = map ord, split //, $data;

for my $i ($start .. $end) {

$state->{mem}[$i] = [$segnum, shift @mem];

}

}

sub label {

my ($state) = @_;

my $segnum = $state->{segnum};

for my $opt (qw(code data vector)) {

my $labels = $state->{$opt}{$segnum} || next;

$state->{mem}[$_][LABEL] = $labels->{$_} for keys %$labels;

}

}

sub labels {

my ($state, $opts) = @_;

my $rangelabels = $opts->{rangelabels};

for my $opt (qw(code data vector constant address codeptr)) {

for my $value (@{$opts->{$opt} || []}) {

my $match = $value =~ /

/x;

$match or die "ERROR: Unrecognized $opt address: $value\n";

my $segnum = $2 || 0;

my $base = hex($3);

my $range = hex($4||0);

my $label = $1 || sprintf "u%2X", $base;

if ($opt =~ /address|codeptr/ and $base > 0xFFFF and $range) {

for (my $off = 0; $off <= $range; ++$off) {

my $addr = $base + $off + ($off << 16);

$state->{$opt}{$segnum}{$addr} = $label;

}

next;

}

my $stride = $opt =~ /address|codeptr/ ? 2 : 1;

for (my $off = 0; $off <= $range; $off += $stride) {

my $addr = $base + $off;

if ($opt !~ /address|codeptr/ and ($addr & 0xFFFF) != $addr) {

warn "WARNING: Out of range $opt: $value\n";

$addr &= 0xFFFF;

}

if (defined $state->{$opt}{$segnum}{$addr}) {

warn sprintf "WARNING: Duplicate $opt: $value: %X\n",

$addr;

next;

}

$state->{$opt}{$segnum}{$addr} =

$off ? $rangelabels ? sprintf "${label}_%X", $off :

$off > 9 ? sprintf "$label+\$%X", $off :

"$label+$off" : $label;

}

}

}

label($state);

}

sub copy {

my ($state) = @_;

my $copy = {%$state}; # Shallow copy state

$copy->{mem} = [@{$state->{mem}}]; # Shallow copy mem

return $copy;

}

sub rel {

my ($i, $offset) = @_;

return ($offset < 128 ? $i+$offset+2 : $i+$offset-256+2) & 0xFFFF;

}

sub addr {

my ($lo, $hi) = @_;

$_ ||= 0 for $lo, $hi;

return $lo + ($hi<<8);

}

sub loc {

my ($state, $i) = @_;

if ($state->{segnum}) {

return sprintf "%04X, segment $state->{segnum}", $i;

}

return sprintf "%04X", $i;

}

sub seglabel {

my ($state, $addr) = @_;

my $label = $state->{mem}[$addr][LABEL];

my $segnum = $state->{mem}[$addr][SEGNUM];

return $label ? $label :

$segnum ? sprintf "${segnum}:%04X", $addr : sprintf "%04X", $addr;

}

sub getbyte {

my ($state, $addr) = @_;

my $mem = $state->{mem};

my $byte = $mem->[$addr];

my $pre = $byte->[SEGNUM] ? sprintf "s$byte->[SEGNUM]" : "";

my $label = $byte->[LABEL] ||= $pre . sprintf "l%04X", $addr;

return ($byte, $label);

}

sub trace {

my ($state, $entry, $callerid, $caller) = @_;

my (undef, undef) = getbyte($state, $entry);

#info(sprintf "; TRACING: %X\n", $entry);

$state->{traced} = 1;

my $mem = $state->{mem};

my $byte = $mem->[$entry] || return;

if (defined $byte->[VALUE] || $byte->[LABEL]) {

if ($callerid) {

push @{$byte->[CALLERS]}, $callerid;

} else {

push @{$byte->[CALLERS]}, seglabel($state, $caller);

}

}

for (my $i = $entry;;) {

my $byte = $mem->[$i] || return; # Ignore undefined memory

my ($code, $i1, $i2) = map $mem->[$_][VALUE], $i .. $i+2;

return if not $code; # Ignore BRK

return if $illegal[$code]; # Ignore illegal opcodes

return if $state->{visited}{$i}++; # Skip if already visited

$byte->[LEN] = $len[$code];

for ($i .. $i+$len[$code]-1) {

if (not defined $mem->[$_][VALUE]) {

# Bail out if instruction goes out-of-bounds

warn "WARNING: Instruction goes past end of state at ",

loc($state, $_), "\n";

return;

}

}

my $mode = $mode[$code];

if ($mn[$code] eq "rts") {

last;

} elsif ($mn[$code] eq "rti") {

last;

} elsif ($mn[$code] eq "jmp") {

my $targ = addr($i1, $i2);

my ($data, $tlabel) = getbyte($state, $targ);

push @{$byte->[TARGETS]}, $tlabel if $tlabel;

if ($mode[$code] eq "Indirect") {

push @{$mem->[$targ][ACCESSORS]}, seglabel($state, $i);

my ($lo, $hi) = map $mem->[$_][VALUE], $targ, $targ+1;

if (defined $lo and defined $hi) {

$targ = addr($lo, $hi);

} else {

warn "WARNING: Indirect JMP references undefined ",

"memory at ", loc($state, $i), "\n";

$targ = undef;

}

}

trace($state, $targ, $byte->[LABEL], $i) if defined $targ;

last;

} elsif ($mn[$code] eq "jsr") {

my $targ = addr($i1, $i2);

my ($data, $tlabel) = getbyte($state, $targ);

push @{$byte->[TARGETS]}, $tlabel if $tlabel;

trace($state, $targ, $byte->[LABEL], $i);

} elsif ($mn[$code] =~ /^b(ne|eq|pl|mi|cc|cs|vs|vc)/) {

my $targ = rel($i, $i1);

my ($data, $tlabel) = getbyte($state, $targ);

push @{$byte->[TARGETS]}, $tlabel if $tlabel;

trace($state, $targ, $byte->[LABEL], $i);

} elsif ($mode =~ /Ind|Z-Page/) {

my ($data, $tlabel) = getbyte($state, $i1);

push @{$byte->[TARGETS]}, $tlabel if $tlabel;

push @{$data->[ACCESSORS]}, seglabel($state, $i);

} elsif ($mode =~ /Absolute/) {

my $addr = addr($i1, $i2);

my ($data, $tlabel) = getbyte($state, $addr);

push @{$byte->[TARGETS]}, $tlabel if $tlabel;

push @{$data->[ACCESSORS]}, seglabel($state, $i);

}

$i += $len[$code];

}

}

sub uniq { my %uniq; grep !$uniq{$_}++, @_ }

sub sortuniq { sort(uniq(@_)) }

sub extern {

my ($opts, $state) = @_;

return if not $opts->{extern};

return if not $opts->{labels};

my @labels;

for (my $addr = 0; $addr < 0x10000; ++$addr) {

my $label = $state->{mem}[$addr][LABEL] or next;

if (not $opts->{__org}{$addr}) {

next if $opts->{labelled}{$label};

next if not $opts->{referenced}{$label};

}

next if $label =~ /\+/;

my $comment = "";

my $accessors = $state->{mem}[$addr][ACCESSORS];

if ($accessors and $opts->{access}) {

$comment .= "\t\t; " . join " ", "Access:", sortuniq @$accessors;

}

my $callers = $state->{mem}[$addr][CALLERS];

if ($callers and $opts->{call}) {

$comment .= "\t\t; " . join " ", "Callers:", sortuniq @$callers;

}

push @labels, [$addr,

sprintf "$label equ \$%X$comment\n", $addr];

}

print "##EXTERN##\n";

print map $_->[1], sort { $a->[0] <=> $b->[0] } @labels;

}

sub dump_label {

my ($opts, $state, $i, $label, $byte, $off) = @_;

return if not $opts->{labels};

return if not $label;

return if $label =~ /\+/;

return if $opts->{__org}{$i};

my $callers = $byte->[CALLERS];

if ($off) {

printf "$label equ *+$off";

if ($opts->{comment}) {

my $accessors = $byte->[ACCESSORS];

if ($accessors and $opts->{access}) {

print "\t\t; Access:";

print " $_" for sortuniq @$accessors;

}

}

} else {

print $label;

}

my $tabs = (3 - ((length $label) >> 3)) || 1;

print (("\t") x $tabs);

if ($callers and $opts->{call}) {

print "; Callers:";

print " $_" for sortuniq @$callers;

}

print "\n";

$opts->{labelled}{$label}++;

}

sub dis {

my ($state, $start, $end, $opts) = @_;

my $mem = $state->{mem};

for (my $i = $start; $i <= $end; ++$i) {

my $byte = $mem->[$i];

my $segnum = $byte->[SEGNUM];

my $value = $byte->[VALUE];

my $len = $byte->[LEN];

my $targets = $byte->[TARGETS];

my $label = $byte->[LABEL];

my $accessors = $byte->[ACCESSORS];

my $bitjmp = $value == 0x2C && $mem->[$i+1][CALLERS];

if (not $bitjmp and $len and $i + $len - 1 <= $end) {

my ($code, $i1, $i2) = map $mem->[$_][VALUE], $i .. $i+2;

dump_label($opts, $state, $i, $label, $byte);

for (my $a = $i+1; $a < $i+$len; ++$a) {

if (my $label = $mem->[$a][LABEL]) {

my $off = $a-$i;

dump_label($opts, $state, $i, $label, $mem->[$a], $off);

}

}

printf " $mn[$code]";

my $mode = $mode[$code];

my $imm8 = $i1||0;

my $imm16 = ($i1||0) + (($i2||0)<<8);

my $rel = rel($i, $i1||0);

my $ab = $i2 ? "" : "a:";

if ($opts->{labels} && $targets && $mode !~ /Accum|Implied/) {

my $targ = $imm8 = $imm16 = $rel = $targets->[-1];

$targ =~ s/\+.*//;

$opts->{referenced}{$targ}++;

} elsif ($mode eq "Immediate" and $state->{constant}{$segnum}{$i1}) {

$imm8 = $state->{constant}{$segnum}{$i1};

$opts->{referenced}{$imm8}++;

} elsif ($opts->{labels} && $mode eq "Immediate" and $mem->[$i+1][ADDRESS]) {

$rel = $mem->[$i+1][ADDRESS];

$mode = "Relative"; # XXX Hack

} else {

$_ = sprintf "\$%02X", $_ for $imm8;

$_ = sprintf "\$%04X", $_ for $imm16, $rel;

}

print " @" if $mode eq "Accumulator";

print " #$imm8" if $mode eq "Immediate";

print " ($imm8),y" if $mode eq "(Ind),Y";

print " ($imm8,x)" if $mode eq "Ind,X";

print " $imm8" if $mode eq "Z-Page";

print " $imm8,x" if $mode eq "Z-Page,X";

print " $imm8,y" if $mode eq "Z-Page,Y";

print " $ab$imm16" if $mode eq "Absolute";

print " $ab$imm16,x" if $mode eq "Absolute,X";

print " $ab$imm16,y" if $mode eq "Absolute,Y";

print " ($imm16)" if $mode eq "Indirect";

print " $rel" if $mode eq "Relative";

print " " if $mode eq "Implied";

if ($opts->{comment}) {

printf "\t\t; %04X:%s", $i, join "",

map { sprintf " %02X", $mem->[$_][VALUE] }

$i .. ($i+$len-1);

if ($accessors and $opts->{access}) {

print " Access:";

print " $_" for sortuniq @$accessors;

}

}

print "\n";

$i += $len - 1;

} else {

dump_label($opts, $state, $i, $label, $byte);

if ($opts->{labels} && $byte->[ADDRESS]) {

printf " dta $byte->[ADDRESS]";

} else {

printf " dta \$%X", $value;

}

if ($opts->{comment}) {

printf "\t\t; %04X: %02X", $i, $value;

if ($accessors and $opts->{access}) {

print " Access:";

print " $_" for sortuniq @$accessors;

}

print " <--- Data" if exists $state->{data}{$segnum}{$i};

print " <--- Bit Jump" if $len and $bitjmp;

}

print "\n";

}

}

}

sub word {

my ($stream, $i) = @_;

$i + 2 < length $stream or die "ERROR: File is corrupted\n";

return unpack "v", substr $stream, $i, 2;

}

sub enter {

my ($state) = @_;

my $mem = $state->{mem};

my $segnum = $state->{segnum};

while (my ($data, $label) = each %{$state->{data}{$segnum}}) {

$label = $label ? "$label=" : "";

info(sprintf "DATA: $label%04X\n", $data);

$state->{visited}{$data} = 1;

}

for my $type (qw(address codeptr)) {

for my $address (sort keys %{$state->{$type}{$segnum}}) {

my $label = $state->{$type}{$segnum}{$address};

my $address_hi;

if ($address > 0xFFFF) {

# Split address

$address_hi = $address >> 16;

$address &= 0xFFFF;

} else {

# Contiguous address

$address_hi = $address + 1;

}

my $from = sprintf "%04X_%04X", $address_hi, $address;

my ($i1, $i2) = map $mem->[$_][VALUE], $address, $address_hi;

my $taddr = addr($i1, $i2);

info(sprintf "ADDRESS: %s,%s = %s\n",

seglabel($state, $address_hi),

seglabel($state, $address),

seglabel($state, $taddr));

my $targ = $mem->[$taddr];

my $pre = $targ->[SEGNUM] ? sprintf "s$targ->[SEGNUM]" : "";

my $tlabel = $targ->[LABEL] ||= $pre . sprintf "l%04X", $taddr;

$mem->[$address][ADDRESS] = "<$tlabel";

$mem->[$address_hi][ADDRESS] = ">$tlabel";

if ($type eq "codeptr") {

info(sprintf "CODE: %04X\n", $taddr);

trace($state, $taddr, sprintf "-P $from");

}

}

}

while (my ($code, $label) = each %{$state->{code}{$segnum}}) {

$label = $label ? "$label=" : "";

next if $label =~ /\+/;

info(sprintf "CODE: $label%04X\n", $code);

trace($state, $code, sprintf "-c %04X", $code);

}

while (my ($vector, $label) = each %{$state->{vector}{$segnum}}) {

$label = $label ? "$label=" : "";

next if $label =~ /\+/;

if (grep !defined $mem->[$_][VALUE], $vector, $vector+1) {

warn "WARNING: Vector through undefined memory: ",

loc($state, $vector), "\n";

next;

}

info(sprintf "VECTOR: $label%04X\n", $vector);

my $targ = addr($mem->[$vector][VALUE], $mem->[$vector+1][VALUE]);

trace($state, $targ, sprintf "-v %04X", $vector);

}

}

sub runini {

my ($opts, $state, $i) = @_;

my $targ = addr($state->{mem}[$i][VALUE], $state->{mem}[$i+1][VALUE]);

my $label = $state->{mem}[$targ][LABEL];

return $opts->{labels} && $label ? $label : sprintf "\$%04X", $targ;

}

sub xex {

my ($stream, $opts) = @_;

my $state = state();

labels($state, $opts);

my @segments;

my $run;

my $run_caller;

my $segstart;

my $extra;

for (my $i = 0; $i < length $stream;) {

$segstart = $i;

++$state->{segnum};

delete $state->{visited};

my $start;

my $ffff;

my $end;

eval {

$start = word($stream, $i);

$i += 2;

$ffff = $start == 0xFFFF;

if ($ffff) {

$start = word($stream, $i);

$i += 2;

}

$end = word($stream, $i);

$i += 2;

1;

} or do {

warn "WARNING: Incomplete segment header at byte $segstart\n";

$extra = substr $stream, $segstart;

last;

};

my $len = $end - $start + 1;

info(sprintf "START: %X END: %X\n", $start, $end);

if ($len < 0) {

warn "WARNING: Segment length is negative ",

"at byte $segstart: $len\n";

$extra = substr $stream, $segstart;

last;

}

warn "WARNING: Segment past EOF at byte $segstart, $len\n"

if $i+$len > length $stream;

my $data = substr $stream, $i, $len;

$end = $start + (length $data) - 1;

$i += $len;

layer($state, $start, $end, $data);

label($state);

enter($state);

if ($start == 0x2E0) {

$run = unpack "v", $data;

info(sprintf "RUN: %X\n", $run);

$run_caller = "run_segment$state->{segnum}";

} elsif ($start == 0x2E2) {

my $ini = unpack "v", $data;

info(sprintf "INI: %X\n", $ini);

trace($state, $ini, "ini_segment$state->{segnum}");

}

push @segments, [$start, $end, $data, copy($state), $ffff];

}

trace($state, $run, $run_caller) if defined $run;

trace($state, $segments[0][0], "COM") if not $state->{traced} and @segments;

$state->{segnum} = 0;

enter($state);

for my $segment (@segments) {

my ($start, $end, $data, $state, $ffff) = @$segment;

if ($state->{segnum}) {

print " ;-------------------------\n";

print " ; Segment $state->{segnum}\n";

print " ;-------------------------\n";

}

my $header = sub {

return unless $ffff and $state->{segnum} > 1;

printf " opt h-\n";

printf " dta a(\$FFFF)\t; Segment header\n";

printf " opt h+\n";

};

if ($start == 0x2E0 and $end == 0x2E1) {

$header->();

printf " run %s\n", runini($opts, $state, 0x2E0);

} elsif ($start == 0x2E2 and $end == 0x2E3) {

$header->();

printf " ini %s\n", runini($opts, $state, 0x2E2);

} else {

my $f = $ffff ? "f:" : "";

if ($opts->{orglabels} && (my $label = $state->{mem}[$start][LABEL])) {

printf " org $f$label ; start %04X end %04X\n",

$start, $end;

$opts->{__org}{$start} = 1;

} else {

printf " org $f\$%04X ; start %04X end %04X\n",

$start, $start, $end;

}

dis($state, $start, $end, $opts);

}

}

if ($extra) {

print " ; Corrupted segment\n";

print " opt h-\n";

printf " dta \$%02X\n", ord($_) for split //, $extra;

}

extern($opts, $state);

}

sub sap {

my ($stream, $opts) = @_;

$stream =~ /(SAP\x0D\x0A.*?)(\xFF\xFF.*)/s or

die "ERROR: Not a SAP file\n";

my $header = $1;

my $binary = $2;

my %attr;

print " opt h-\n";

while ($header =~ /(.*?)(?: (.*?))?\x0D\x0A/gs) {

my ($key, $value) = ($1, $2);

if (defined $value) {

$attr{$key} = $value;

$value =~ s/'/',c"'",c'/g;

print " dta c'$key $value',13,10\n";

} else {

$attr{$key} = 1;

print " dta c'$key',13,10\n";

}

}

print " opt h+\n";

if ($attr{TYPE} eq "C") {

my $player = hex($attr{PLAYER}||0);

push @{$opts->{code}}, sprintf "%X", $player+3;

push @{$opts->{code}}, sprintf "%X", $player+6;

} else {

push @{$opts->{code}}, map "$_=$attr{$_}",

grep defined $attr{$_}, qw(INIT PLAYER);

}

xex($binary, $opts);

}

sub prg {

my ($stream, $opts) = @_;

my $start = unpack "v", substr $stream, 0, 2;

my $end = $start + (length $stream) - 3;

if ($stream =~ /^......\x9E *(\d+)/s) {

push @{$opts->{code}}, sprintf "%X", $1;

}

printf " opt h-\n";

printf " dta a(\$%04X)\t; PRG Header\n", $start;

$opts->{org} = sprintf "%X", $start;

raw((substr $stream, 2), $opts);

}

sub raw {

my ($stream, $opts) = @_;

my $start = hex($opts->{org}||0);

my $end = $start + (length $stream) - 1;

printf " opt h-\n" unless $opts->{headers};

printf " org \$%04X\n", $start;

my $state = state();

layer($state, $start, $end, $stream);

labels($state, $opts);

enter($state);

dis($state, $start, $end, $opts);

extern($opts, $state);

}

sub arg {

my ($opts, $args, $file) = @_;

return if grep $file eq $_, $opts->{arg};

open my $fh, $file or die "ERROR: Cannot open $file: $!\n";

my %args = map { /(\w+)/; my $a = $1; $a => [/=s/, /@/] } @$args;