Yet another implementation for the HACK Assembler outlined in NAND2Tetris

hasm

#!/usr/bin/env perl

use Modern::Perl;
use File::Temp;
use Const::Fast;

use experimental qw( switch );

die "An input file is expected" if not defined $ARGV[0];
die "An output must be specified" if not defined $ARGV[1];

open my $ASM_SBL_FH, '<:utf8', $ARGV[0]
  or die "Failed to open an internal filehandle for $ARGV[0]: $!";

open my $ASMFH, '<:utf8', $ARGV[0]
  or die "Failed to open $ARGV[0]: $!";

my %sbls = ( SP   => 0, LCL  => 1, ARG  => 2, THIS => 3, THAT => 4,

             R0  => 0,  R1  => 1,  R2  => 2,  R3  => 3,
             R4  => 4,  R5  => 5,  R6  => 6,  R7  => 7,
             R8  => 8,  R9  => 9,  R10 => 10, R11 => 11,
             R12 => 12, R13 => 13, R14 => 14, R15 => 15,

             SCREEN => 16384,
             KBD => 24576 );

const my $ains_pattern => qr/^@(.+)$/;
const my $dest_pattern => qr/([AMD]{1,3})=/;
const my $jump_pattern => qr/;(J(?:(?:[LG][TE])|EQ|NE|MP))/;
const my $labe_pattern => qr/\(([^()]+)\)/;
const my $comp_pattern => qr/([0AMD] | -?1 | [!-][AMD] | [AMD][+-]1 | D[&|+-][AM] | [AM]-D)/x;

sub __asmread {
  my $fh = shift;
  my %callbacks = @_;

  LINE:
  while ( <$fh> ) {
    chomp; my $expr = $_;
    s/^(.*?)\/{2}.*$/$1/g;
    s/\s//g;

    next LINE unless length > 0;

    if    ( /$ains_pattern/ ) { &{ $callbacks{ ainst } }($1) if exists $callbacks{ ainst } }
    elsif ( /$labe_pattern/ ) { &{ $callbacks{ label } }($1) if exists $callbacks{ label } }
    elsif ( /^
             $dest_pattern?
             $comp_pattern
             $jump_pattern?
             $
            /x )              { &{ $callbacks{ cinst } }({ d => $1, c => $2, j => $3 }) if exists $callbacks{ cinst } }
    else                      { die "Invalid expression: $expr" }
  }
}

my ( $TMP_HACK_FH, $TMP_HACK_FN ) = File::Temp::tempfile();
binmode( $TMP_HACK_FH, ':utf8' );

my $rom_offset = 0;
my $ram_offset = 16;

__asmread $ASM_SBL_FH, ( ainst => sub { $rom_offset++ },
                         cinst => sub { $rom_offset++ },
                         label => sub { $sbls{ $1 } = $rom_offset }, );
close $ASM_SBL_FH;

print "$_ => $sbls{ $_ }\n" foreach keys %sbls;

__asmread $ASMFH, (
  ainst => sub {
    my ( $sbl, $addr ) = ( $1, $1 );
    if ( not $sbl =~ /^-?(0|([1-9][0-9]*))$/ ) {
      if ( exists $sbls{ $sbl } ) {
        $addr = $sbls{ $sbl }
      } else { # if what we run into is a label
        $sbls{ $sbl } = $addr = $ram_offset++
      }
    }
    my $v15 = substr unpack( 'B32', pack( 'N', $addr ) ), 17, 15;
    print $TMP_HACK_FH '0' . $v15 . "\n";
  },

  cinst => sub {
    my $h = shift;
    printf $TMP_HACK_FH "111%s%s%s\n", comp_opc( $h->{c} ), dest_opc( $h->{d} ), jump_opc( $h->{j} );
  },
);

close $ASMFH;

close $TMP_HACK_FH;
rename $TMP_HACK_FN, $ARGV[1];

sub dest_opc {
  if ( defined $_[0] ) {
    given ( $_[0] ) {
      when ( 'M' )           { return '001' }
      when ( 'D' )           { return '010' }
      when ( /^(?:MD|DM)$/ ) { return '011' }
      when ( 'A' )           { return '100' }
      when ( /^(?:AM|MA)$/ ) { return '101' }
      when ( /^(?:AD|DA)$/ ) { return '110' }
      when ( /^
              (?:
                AMD|ADM
              | MAD|MDA
              | DAM|DMA
              )
              $/x )          { return '111' }
    }
  }
  '000'
}

sub jump_opc {
  if ( defined $_[0] ) {
    given ( $_[0] ) {
      when ( 'JGT' ) { return '001' }
      when ( 'JEQ' ) { return '010' }
      when ( 'JGE' ) { return '011' }
      when ( 'JLT' ) { return '100' }
      when ( 'JNE' ) { return '101' }
      when ( 'JLE' ) { return '110' }
      when ( 'JMP' ) { return '111' }
    }
  }
  '000'
}

sub comp_opc {
  my $opc = 0;

  if ( defined $_[0] ) {
    const my $ADDFLAG => 0b01_00_00_00;
    my $flagopc = qq{ \$opc |= \$ADDFLAG if \$1 eq 'M' };
    given ( $_[0] ) {
      when ( '0' )          { $opc = 0b10_10_10 }
      when ( '1' )          { $opc = 0b11_11_11 }
      when ( '-1' )         { $opc = 0b11_10_10 }
      when ( 'D' )          { $opc = 0b00_11_00 }
      when ( /^(A|M)$/ )    { $opc = 0b11_00_00;  eval $flagopc }
      when ( '!D' )         { $opc = 0b00_11_01 }
      when ( /^!(A|M)$/ )   { $opc = 0b11_00_01;  eval $flagopc }
      when ( '-D' )         { $opc = 0b00_11_11 }
      when ( /^-(A|M)$/ )   { $opc = 0b11_00_11;  eval $flagopc }
      when ( 'D+1' )        { $opc = 0b01_11_11 }
      when ( /^(A|M)\+1$/ ) { $opc = 0b11_01_11;  eval $flagopc }
      when ( 'D-1' )        { $opc = 0b00_11_10 }
      when ( /^(A|M)-1$/ )  { $opc = 0b11_00_10;  eval $flagopc }
      when ( /^D\+(A|M)$/ ) { $opc = 0b00_00_10;  eval $flagopc }
      when ( /^D-(A|M)$/ )  { $opc = 0b01_00_11;  eval $flagopc }
      when ( /^(A|M)-D$/ )  { $opc = 0b00_01_11;  eval $flagopc }
      when ( /^D&(A|M)$/ )  { $opc = 0b00_00_00;  eval $flagopc }
      when ( /^D\|(A|M)$/ ) { $opc = 0b01_01_01;  eval $flagopc }
    }
  }
  substr unpack( "B32", pack( 'N', $opc ) ), 25, 7;
}