File Coverage

blib/lib/Language/BF.pm

Criterion	Covered	Total	%
statement	41	95	43.1
branch	5	32	15.6
condition	0	5	0.0
subroutine	9	24	37.5
pod	10	13	76.9
total	65	169	38.4

package Language::BF;
use 5.008001;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.3 $ =~ /(\d+)/g;

sub new($;$$) {
    my $class = shift;
    my $bf = bless {}, $class;
    $bf->code(shift)  if @_;
    $bf->input(shift) if @_;
    $bf;
}

sub new_from_file {
    my $bf    = shift->new();
    my $bfile = shift or die __PACKAGE__, "->new_from_file(filename)";
    open my $fh, "<", $bfile or die "$bfile:$!";
    my $src = do { local $/; <$fh> };
    close $fh;
    $bf->code($src);
    $bf;
}

sub reset($){
    my $bf = shift;
    ( $bf->{pc}, $bf->{sp} ) = ( 0, 0 );
    ( $bf->{data}, $bf->{in}, $bf->{out} ) = ( [], [], [] );
    $bf;
}

sub code($$) {
    my ( $bf, $code ) = @_;
    $code =~ tr/<>+\-.,[]//cd;
    $bf->{code} = [ split //, $code ];
    my $coderef = $bf->compile;
    warn $coderef unless ref $coderef;
    $bf->{coderef} = $bf->compile;
    $bf->reset;
    $bf;
}
*parse = \&code;

sub compile($){
    my $bf  = shift;
    my $src = <<'EOS';
sub {
my (@data, @out) = ();
my $sp = 0;
EOS
    for my $op ( @{ $bf->{code} } ) {
        $src .= {
            '<' => '$sp--;',
            '>' => '$sp++;',
            '+' => '$data[$sp]++;',
            '-' => '$data[$sp]--;',
            '.' => 'push @out, $data[$sp];',
            ',' => '$data[$sp] = shift @_;',
            '[' => 'while($data[$sp]){',
            ']' => '}',
          }->{$op}
          . "\n";
    }
    $src .= <<'EOS';
return @out
}
EOS
    my $coderef = eval $src;
    return $@ ? $@ : $coderef;
}

sub run($;$){
    my ($bf, $interpret) = shift;
    if ($interpret){
	$bf->step while ( $bf->{code}[ $bf->{pc} ] and $bf->{pc} >= 0 );
    }else{
	$bf->{out} = [ $bf->{coderef}($bf->{in}) ];
    }
}

sub debug { my $bf = shift; $bf->{debug} = shift if @_;  $bf->{debug} };

sub input($$){
    my ($bf, $input) = @_;
    $bf->{in} =  [ split //, $input ];
    $bf;
}

sub output($){
    my $bf = shift;
    join '', map {chr} @{$bf->{out}};
}

sub as_source($) {
    my $bf = shift;
    require B::Deparse;
    B::Deparse->new()->coderef2text( $bf->{coderef} );
}

sub as_perl($) {
    'print map{chr} sub'. $_[0]->as_source
	. '->(split//, do{local $/;my $s=<>})' . "\n";
}

sub step($){
    my $bf = shift;
    my $op = $bf->{code}[ $bf->{pc} ];
    $bf->{debug}
      and warn sprintf "pc=%d, sp=%d, op=%s", $bf->{pc}, $bf->{sp}, $op;
    {
        '<' => sub { $bf->{sp} -= 1 },
        '>' => sub { $bf->{sp} += 1 },
        '+' => sub { $bf->{data}[ $bf->{sp} ]++ },
        '-' => sub { $bf->{data}[ $bf->{sp} ]-- },
        '.' => sub { push @{ $bf->{out} }, $bf->{data}[ $bf->{sp} ] },
        ',' => sub { $bf->{data}[ $bf->{sp} ] = shift @{ $bf->{in} } },
        '[' => sub {
            return if $bf->{data}[ $bf->{sp} ];
            my $nest = 1;
            while ($nest) {
                $bf->{pc} += 1;
                $nest     +=
                    $bf->{code}[ $bf->{pc} ] eq '[' ? +1
                  : $bf->{code}[ $bf->{pc} ] eq ']' ? -1
                  : 0;
		die "matching ] not found!"
		    if $bf->{pc} > scalar @{ $bf->{code} };
            }
        },
        ']' => sub {
            my $nest = 1;
            while ($nest) {
                $bf->{pc} -= 1;
                $nest     -=
                    $bf->{code}[ $bf->{pc} ] eq '[' ? +1
                  : $bf->{code}[ $bf->{pc} ] eq ']' ? -1
                  : 0;
		die "matching [ not found!"
		    if $bf->{pc} < 0;
            }
	    $bf->{pc}--;
        },
    }->{$op}();
    $bf->{pc}++;
}

sub as_c($;$){
    my $bf  = shift;
    my $datasize = shift || 65536;
    my $src = <<"EOS";
int main(int argc, char **argv){
char data[$datasize];
int  sp = 0;
EOS
    for my $op ( @{ $bf->{code} } ) {
        $src .= {
            '<' => 'sp--;',
            '>' => 'sp++;',
            '+' => 'data[sp]++;',
            '-' => 'data[sp]--;',
            '.' => 'putchar(data[sp]);',
            ',' => 'data[sp] = getchar();',
            '[' => 'while(data[sp]){',
            ']' => '}',
          }->{$op}
          . "\n";
    }
    $src .= <<'EOS';
}
EOS
    return $src;
}


1;
__END__