File Coverage

blib/lib/CPU/Emulator/DCPU16/Assembler.pm

Criterion	Covered	Total	%
statement	79	85	92.9
branch	46	62	74.1
condition	7	15	46.6
subroutine	6	6	100.0
pod	1	1	100.0
total	139	169	82.2

package CPU::Emulator::DCPU16::Assembler;
use strict;

=head1 NAME

CPU::Emulator::DCPU16::Assembler -  assemble DCPU-16 bytecode

=head1 SYNOPSIS

    # Assemble a program
    my $bytes = CPU::Emulator::DCPU16::Assembler->assemble($asm);

    # Then either run it ...
    my $cpu   = CPU::Emulator::DCPU16->new();
    $cpu->load($bytes);
    $cpu-run;

    # ... or disassemble it
    my $asm   = CPU::Emulator::DCPU16::Disassembler->dump($bytes);

=head1 METHODS

=cut

=head2 assemble

Return bytes representing an assembled program

=cut
sub assemble {
    my $class  = shift;
    my $asm    = shift;
    my $bytes  = "";
    my %labels = ();
    my %unres  = ();
    my $idx    = 1;
    for my $line (split /\n/, $asm) {
        $class->_parse_line($line, $idx++, \$bytes, \%labels, \%unres);
    }
    $class->_resolve_references(\$bytes, \%labels, \%unres);
    return $bytes;
}


our %_EXTENDED_OPS = (JSR => 0x01);
our %_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);

sub _parse_line {
    my $class  = shift;
    my $line   = shift;
    my $idx    = shift;
    my $bytes  = shift;
    my $labels = shift;
    my $unres  = shift;
    my $off    = length($$bytes)/2;
    my $oc;

    # trim and clean the line
    $line =~ s!(^\s*|\s*$|;.*$)!!g;
    return unless length($line);

    my ($label, $op, $a, $b) = $line =~ m!
        ^
        (?::(\w+)      \s+)? # optional label
        ([A-Za-z]+)    \s+   # opcode
        ([^,\s]+) (?:, \s+   # operand
        ([^,\s]+))?    \s*   # optional second opcode
        $
    !x;

    die "Couldn't parse line $idx: $line\n" unless defined $op;

    $labels->{$label} = $off if defined $label;

    $op = uc $op;
    if ($oc = $_EXTENDED_OPS{$op}) {
        die "$op takes one operand at line $idx: $line\n" unless defined $a && !defined $b;
        my ($val, $next_word, $label) = _parse_operand($a);
        die "Can't parse operand '$a' at line $idx: $line\n" unless defined $val;

        $oc <<= 4;
        $oc |= $val << 10;

        $unres->{$off} = [$label] if defined $label;
        $$bytes .= pack("S>", $oc);
        $$bytes .= pack("S>", $next_word) if defined $next_word;

    } elsif ($oc = $_OPS{$op}) {
         die "$op takes two operands at line $idx: $line\n" unless defined $a && defined $b;

         my ($val_a, $next_word_a, $label_a) = _parse_operand($a);
         die "Can't parse operand '$a' at line $idx: $line\n" unless defined $val_a;
         my ($val_b, $next_word_b, $label_b) = _parse_operand($b);
         die "Can't parse operand '$b' at line $idx: $line\n" unless defined $val_b;

         $oc |= $val_a << 4;
         $oc |= $val_b << 10;
         $unres->{$off} = [$label_a, $label_b] if defined $label_a || defined $label_b;

         $$bytes .= pack("S>", $oc);
         $$bytes .= pack("S>", $next_word_a) if defined $next_word_a;
         $$bytes .= pack("S>", $next_word_b) if defined $next_word_b;
    } else {
        die "Unknown opcode $op at line $idx: $line\n";
    }


}

sub _parse_num {
    my $num = shift;
    $num    = oct($num) if $num =~ /^0x/i;
    $num;
}

sub _parse_operand {
    my $op   = shift;
    my $regs = "ABCXYZIJ";
    my $nums = qr/(?:0x[0-9A-F]+|[0-9]+)/i;

    if (0<=index $regs, $op) {
        return (index $regs, $op);
    } elsif ($op =~ /^\[\s*([$regs])\s*\]$/) {
        return (0x08 + index $regs, uc($1));
    } elsif ($op =~ /^\[\s*($nums)\s*\+\s*([$regs])\s*\]$/) {
        return (0x10 + index($regs, uc($2)), _parse_num($1));
    } elsif ($op eq 'POP' || $op =~ /^\[\s*SP\+\+\s*\]$/) {
        return (0x18);
    } elsif ($op eq 'PEEK' || $op =~ /^\[\s*\-\-SP\s*\]$/) {
        return (0x19);
    } elsif ($op eq 'PUSH') {
        return (0x1a);
    } elsif ($op eq 'SP') {
        return (0x1b);
    } elsif ($op eq 'PC') {
        return (0x1c);
    } elsif ($op eq 'O') {
        return (0x1d);
    } elsif ($op =~ /^\[\s*($nums)\s*\]$/) {
        return (0x1e, _parse_num($1));
    } elsif ($op =~ /^($nums)$/) {
        my $num = _parse_num($1);
        return ($num < 0x20) ? (0x20 + $num) : (0x1f, $num);
    } elsif ($op =~ /\w+/) {
        return (0x1f, 0x00, $op);
    } else {
        return ();
    }
}

sub _resolve_references {
    my $class  = shift;
    my $bytes  = shift;
    my $labels = shift;
    my $unres  = shift;

    foreach my $pos (reverse sort { $a <=> $b } keys %$unres) {
        my @labels = grep { defined } @{ delete $unres->{$pos} };
        next unless @labels;

        my $offset = 2;
        for my $label (@labels) {
            my $resolved = $labels->{$label};
            die "Can't resolve label $label" unless defined $resolved;
            substr($$bytes, $pos * 2 + $offset, 2, pack("S>", $resolved));
            $offset += 2;
        }
    }
}



1;