From 8afefbfb5d3978deeddb40b03b4a5a9d1ad240f0 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Thu, 5 Apr 2012 22:32:10 -0500 Subject: add an assembler --- bin/dcpu16-asm | 22 ++++ lib/Games/Emulation/DCPU16/Assembler.pm | 227 ++++++++++++++++++++++++++++++++ 2 files changed, 249 insertions(+) create mode 100644 bin/dcpu16-asm create mode 100644 lib/Games/Emulation/DCPU16/Assembler.pm 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; -- cgit v1.2.3-54-g00ecf