add an assembler

2 files changed, 249 insertions, 0 deletions

diff --git a/bin/dcpu16-asm b/bin/dcpu16-asm
new file mode 100644
index 0000000..1245236
--- /dev/null
+++ b/bin/dcpu16-asm
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Games::Emulation::DCPU16::Assembler;
+use Getopt::Long;
+
+my $out = 'a.out';
+GetOptions(
+    'output=s' => \$out,
+);
+
+my $file = $ARGV[0];
+open my $fh, '<', $file or die "Couldn't open $file for reading: $!";
+my $script = do { local $/; <$fh> };
+
+my $assembler = Games::Emulation::DCPU16::Assembler->new;
+my $bin = $assembler->assemble($script);
+
+open my $outfh, '>', $out or die "Couldn't open $out for writing: $!";
+print $outfh $bin;
+close $outfh or die "Couldn't close $out: $!";
diff --git a/lib/Games/Emulation/DCPU16/Assembler.pm b/lib/Games/Emulation/DCPU16/Assembler.pm
new file mode 100644
index 0000000..679550c
--- /dev/null
+++ b/lib/Games/Emulation/DCPU16/Assembler.pm
@@ -0,0 +1,227 @@
+package Games::Emulation::DCPU16::Assembler;
+use strict;
+use warnings;
+
+sub new {
+    my $class = shift;
+    bless {
+        bytes      => '',
+        line       => 0,
+
+        labels     => {},
+        unresolved => {},
+
+        basic_ops => {
+            SET => 0x01,
+            ADD => 0x02,
+            SUB => 0x03,
+            MUL => 0x04,
+            DIV => 0x05,
+            MOD => 0x06,
+            SHL => 0x07,
+            SHR => 0x08,
+            AND => 0x09,
+            BOR => 0x0a,
+            XOR => 0x0b,
+            IFE => 0x0c,
+            IFN => 0x0d,
+            IFG => 0x0e,
+            IFB => 0x0f,
+        },
+        non_basic_ops => {
+            JSR => 0x01,
+            HLT => 0x3f,
+        },
+        registers => {
+            A => 0x00,
+            B => 0x01,
+            C => 0x02,
+            X => 0x03,
+            Y => 0x04,
+            Z => 0x05,
+            I => 0x06,
+            J => 0x07,
+        },
+    }, $class;
+}
+
+sub bytes { shift->{bytes} }
+
+sub assemble {
+    my $self = shift;
+    my ($script) = @_;
+
+    for my $line (split /\n/, $script) {
+        $self->parse_line($line);
+    }
+
+    $self->resolve_references;
+
+    return $self->{bytes};
+}
+
+sub parse_line {
+    my $self = shift;
+    my ($line) = @_;
+
+    $self->{line}++;
+
+    my $clean_line = $self->_clean_line($line);
+    return unless length($clean_line);
+
+    my ($label, $op, $a, $b) = $clean_line =~ m!
+        ^              \s*
+        (?::(\w+)      \s+)?
+        ([A-Z]{3})     \s+
+        ([^,\s]+) (?:, \s+
+        ([^,\s]+))?    \s*
+        $
+    !x;
+
+    die "Couldn't parse \"$line\" (line $self->{line})"
+        unless defined $op;
+
+    $self->{labels}{$label} = length($self->{bytes}) / 2
+        if defined $label;
+
+    $op = uc($op);
+    if (my $basic_opcode = $self->{basic_ops}{$op}) {
+        die "$op requires two values (line $self->{line})"
+            unless defined($b);
+
+        my ($val1, $next_word1, $label1) = $self->_parse_value($a);
+        my ($val2, $next_word2, $label2) = $self->_parse_value($b);
+
+        $basic_opcode |= $val1 << 4;
+        $basic_opcode |= $val2 << 10;
+
+        $self->{unresolved}{length($self->{bytes}) / 2} = [ $label1, $label2 ]
+            if defined($label1) || defined($label2);
+
+        $self->{bytes} .= pack("S>", $basic_opcode);
+        $self->{bytes} .= pack("S>", $next_word1) if defined $next_word1;
+        $self->{bytes} .= pack("S>", $next_word2) if defined $next_word2;
+    }
+    elsif (my $non_basic_opcode = $self->{non_basic_ops}{$op}) {
+        my ($val, $next_word, $label) = $self->_parse_value($a);
+
+        $non_basic_opcode <<= 4;
+        $non_basic_opcode |= $val << 10;
+
+        $self->{unresolved}{length($self->{bytes}) / 2} = [ $label ]
+            if defined($label);
+
+        $self->{bytes} .= pack("S>", $non_basic_opcode);
+        $self->{bytes} .= pack("S>", $next_word) if defined $next_word;
+    }
+    else {
+        die "Invalid op: $op (line $self->{line})";
+    }
+}
+
+sub resolve_references {
+    my $self = shift;
+
+    for my $pos (reverse sort { $a <=> $b } keys %{ $self->{unresolved} }) {
+        my @labels = grep { defined } @{ delete $self->{unresolved}{$pos} };
+        next unless @labels;
+
+        my $offset = 2;
+        for my $label (@labels) {
+            die "Unknown label $label (during resolution)"
+                unless exists $self->{labels}{$label};
+
+            # XXX collapse small integers
+            substr(
+                $self->{bytes},
+                $pos * 2 + $offset,
+                2,
+                pack("S>", $self->{labels}{$label})
+            );
+            $offset += 2;
+        }
+    }
+}
+
+sub _clean_line {
+    my $self = shift;
+    my ($line) = @_;
+
+    $line =~ s/;.*//;
+    $line =~ s/^\s*|\s*$//;
+    $line =~ s/\s+/ /g;
+
+    return $line;
+}
+
+sub _parse_value {
+    my $self = shift;
+    my ($value) = @_;
+
+    my $reg = qr/[ABCXYZIJ]/;
+    my $num = qr/(?:0[xb])?[0-9]+/;
+
+    if ($value =~ /^($reg)$/) {
+        return ($self->{registers}{$1});
+    }
+    elsif ($value =~ /^\[\s*($reg)\s*\]$/) {
+        return (0x08 + $self->{registers}{$1});
+    }
+    elsif ($value =~ /^\[\s*($num)\s*\+\s*($reg)\s*\]$/) {
+        return (0x10 + $self->{registers}{$2}, $self->_parse_num($1));
+    }
+    elsif ($value eq 'POP'  || $value =~ /^\[\s*SP\+\+\s*\]$/) {
+        return (0x18);
+    }
+    elsif ($value eq 'PEEK' || $value =~ /^\[\s*SP\s*\]$/) {
+        return (0x19);
+    }
+    elsif ($value eq 'PUSH' || $value =~ /^\[\s*--SP\s*\]$/) {
+        return (0x1a);
+    }
+    elsif ($value eq 'SP') {
+        return (0x1b);
+    }
+    elsif ($value eq 'PC') {
+        return (0x1c);
+    }
+    elsif ($value eq 'O') {
+        return (0x1d);
+    }
+    elsif ($value =~ /^\[\s*($num)\s*\]$/) {
+        return (0x1e, $self->_parse_num($1));
+    }
+    elsif ($value =~ /^($num)$/) {
+        my $num = $self->_parse_num($1);
+        if ($num < 0x20) {
+            return 0x20 + $num;
+        }
+        else {
+            return (0x1f, $self->_parse_num($1));
+        }
+    }
+    elsif ($value =~ /\w+/) {
+        return (0x1f, 0x00, $value);
+    }
+    else {
+        die "Can't parse value \"$value\" (line $self->{line})";
+    }
+}
+
+sub _parse_num {
+    my $self = shift;
+    my ($num) = @_;
+
+    die "Invalid number $num (line $self->{line})"
+        unless $num =~ /^(?:0[xb])?[0-9]+/;
+
+    my $decimal = $num;
+    $decimal = oct($num) if $num =~ /^0/;
+
+    die "Number $decimal too large (line $self->{line})"
+        if $decimal >= 2**16;
+
+    return $decimal;
+}
+
+1;