Brainfuck Compiler (*.com)

package Brainfuck::Compiler;

use 5.014;
use strict;
use warnings;

my @valid_ops = my ($op_plus, $op_minus, $op_next, $op_previus, $op_begin, $op_end, $op_put, $op_get) = map(ord, ('+', '-', '>', '<', '[', ']', '.', ','));
my @optimizable_ops = ($op_plus, $op_minus, $op_next, $op_previus);

#my $cell_max = 255;
my %_container = (size => 0x1000,
                  base => 0xFFFF - 0x1000);
                        # 0xFFFF = max addressing
                        # 0x1000 = container size
my %_cell      = (max  => 0xFF,
                  min  => 0x00);

sub new {
    my $class = shift;
    return bless {}, $class;
}

sub compile {
    my ($self, $c) = @_;
    my @cb = map(ord, split(//, $c));
    my @cc = $self->strip_comments(\@cb);
    my @oc = $self->optimize(\@cc);
    my @bt = $self->build(\@oc);
    my $bin = $self->write(\@bt);
    return $bin;
}

sub optimize {
    my ($self, $cc) = @_;
    my @oc;
    my $cs = scalar @{$cc};

    for(my $cp = 0; $cp < $cs; $cp++) {
        my $op = $cc->[$cp];
        my $opc = 0;

        if($self->can_optimize($op)) {
            while($cc->[$cp] == $op) {
                $opc++;
                $cp++;
                # fix: this is only effective with + and -
                if($opc > $_cell{'max'}) {
                    $opc = 0;
                }
                if($cp == $cs) {
                    last;
                }
            }
            $cp--;
        }
        push(@oc, {op => $op, count => $opc});
    }

    return @oc;
}

# return a little-endian unsigned short int binary representation of a number
sub _binShort {
    my $value = shift;

    return pack("s", $value);
}

# return a unsigned byte binary representation of a number
sub _binByte {
    my $value = shift;

    return pack("C", $value);
}

# this will fill all cells with 0 and set DI register to 0
sub _startup {
    #Intel 8086 Assembly code
    return "\xBB". _binShort($_container{"base"}).
          # mov bx, $container_base
           "\xB9". _binShort($_container{"size"}).
          # mov cx, $container_size
          # loop_start:
           "\xC6\x07\x00".
          # mov [bx], 0
           "\x43".
          # inc bx
           "\xE2\xFA".
          # loop loop_start
           "\xBF\x00\x00";
          # mov di, 0

    # Same code in Perl
    # $bx = $container_base
    # for $cx (0..$container_size) {
    #     MEM[$bx] = 0;
    #     $bx++;
    # }
    # $di = 0;
}

sub _incPtr {
    my($value) = shift;

    #Intel 8086 Assembly code
    return "\x81\xC7". _binShort($value).
          # add di, $value
           "\x81\xFF". _binShort($_container{"size"}).
          # cmp di, $container_size
           "\x7E\x05".
          # jle less_or_qual
           "\x81\xEF". _binShort($_container{"size"}).
          # sub di, $container_size
           "\x4F";
          # dec di
          # less_or_equal

    # Same code in Perl
    # $di+= $value
    # if($di > $container_size) {
    #     $di-= $container_size;
    #     $di--;
    # }
}

sub _decPtr {
    my($value) = shift;

    return "\x81\xEF". _binShort($value).
          # sub di, $value
           "\x73\x09".
          # jnc no_underflow
           "\xF7\xD7".
          # not di
           "\xBB". _binShort($_container{"size"}).
          # mov bx, $container_size
           "\x2B\xDF".
          # sub bx, di
           "\x8B\xFB";
          # mov di, bx
          # no_underflow:

    # Same code in Perl
    # $di-= $value
    # TODO: terminar
}

sub _incCell {
    my($value) = shift;

    return "\x80\x85". _binShort($_container{"base"}). _binByte($value);
          # add [di + $container_base], $value

    # Same code in Perl
    # MEM[$di + $container_base]+= $value
}

sub _decCell {
    my($value) = shift;

    return "\x80\xAD". _binShort($_container{"base"}). _binByte($value);
          # sub [di + $container_base], $value

    # Same code in Perl
    # MEM[$di + $container_base]-= $value
}

sub _printCell {
    my $value = shift;

    return "\xB4\x02".
          # mov ah, 2
           "\x8A\x95". _binShort($_container{"base"}).
          # mov dl, [di + $container_base]
           "\xCD\x21";
          # int 21h

    # Same code in Perl
    #
}

sub _readInCell {
    return "\xB4\x01".
          # mov ah, 1
           "\xCD\x21".
          # int 21h
           "\x88\x85". _binShort($_container{"base"});
          # mov [di + $container_base], al

    # Same code in Perl
    #
}

sub _beginLoop {
    my $end = shift;

    return "\x80\xBD". _binShort($_container{"base"}). "\x00".
          # cmp [di + $container_base], 0
           "\x75\x03".
          # jne hack
           "\xE9". _binShort($end);
          # jmp $end
          # hack
}

sub _endLoop {
    my $start = shift;
    return "\xE9". _binShort($start);
          # jmp $start
}

sub build {
    my ($self, $oc) = @_;
    my $ocs = scalar @{$oc};
    my @bt;
    my $bin_size = 0;

    for(my $i = 0; $i < $ocs; $i++) {
        my $oop = $oc->[$i];
        my $inst = '';

        given($oop->{'op'}) {
            when ($op_plus) {
                $inst = _incCell($oop->{"count"});
            }
            when ($op_minus) {
                $inst = _decCell($oop->{"count"});
            }
            when ($op_next) {
                $inst = _incPtr($oop->{"count"});
            }
            when ($op_previus) {
                $inst = _decPtr($oop->{"count"});
            }
            when ($op_put) {
                $inst = _printCell();
            }
            when ($op_get) {
                $inst = _readInCell();
            }
            when ($op_begin) {
                $inst = _beginLoop(0);
            }
            when ($op_end) {
                $inst = _endLoop(0);
            }
        }
        $bin_size+= length $inst;
        push(@bt, {op => $oop->{'op'}, instruction => $inst, offset => $bin_size});
    }

    sub find_end {
        my $from = shift() + 1;
        my @bt = @_;
        my $skip = 0;

        for my $i($from..$#bt) {
            given($bt[$i]->{'op'}) {
                when ($op_begin) {
                    $skip++;
                }
                when ($op_end) {
                    return $i if(!$skip);
                    $skip--;
                }
            }
        }
    }

    for my $i(0..$#bt) {
        if($bt[$i]->{'op'} == $op_begin) {
            my $end = find_end($i, @bt);
            $bt[$i]->{'instruction'} = _beginLoop($bt[$end]->{'offset'} - $bt[$i]->{'offset'});
            $bt[$end]->{'instruction'} = _endLoop(-($bt[$end]->{'offset'} - ($bt[$i]->{'offset'} - length($bt[$i]->{'instruction'}))));
        }
    }

    return @bt;
}

sub write {
    my ($self, $bt) = @_;
    my $bts = scalar @{$bt};
    my $bin = _startup();#"\xBF\x00\x00"; # mov DI, 0

    for(my $i = 0; $i < $bts; $i++) {
        my $it = $bt->[$i];
        $bin .= $it->{'instruction'};
    }
    $bin .= "\xC3"; # ret
    return $bin;
}

sub strip_comments {
    my ($self, $c) = @_;
    return grep {$self->is_valid_op($_)} @{$c};
}

sub can_optimize {
    my ($self, $op) = @_;

    return $op~~@optimizable_ops;
}

sub is_valid_op {
    my ($self, $op) = @_;

    return $op~~@valid_ops;
}

1;