Einfacher Interpreter einer einfachen Sprache

Nachdem Jörg mir ein paar Perl-Bücher geliehen hatte und schon seit längerer Zeit das „Hello World!“ Plakat auf unserem stillen Örtchen hängt, musste ich mich einfach an einen Brainfuck Interpreter versuchen.

Und hier ist das Ergebnis:

#!/usr/bin/perl
{
  package BF;
  use strict;
  use warnings;

  my @REGISTERS=('PP', 'MP', 'LOOP');
  my %OPERATORS=(
      '+' => sub {
          my ($self) = @_;
          return if $self->{_registers}{'LOOP'} < 0;
          $self->{_memory}[$self->{_registers}{'MP'}]++;
          $self->{_registers}{'PP'}++;
      },
      '-' => sub {
          my ($self) = @_;
          return if $self->{_registers}{'LOOP'} < 0;
          $self->{_memory}[$self->{_registers}{'MP'}]--;
          $self->{_registers}{'PP'}++;
      },
      '.' => sub {
          my ($self) = @_;
          return if $self->{_registers}{'LOOP'} < 0;
          push @{ $self->{_output} }, $self->{_memory}[$self->{_registers}{'MP'}];
          $self->{_registers}{'PP'}++;
      },
      '>' => sub {
          my ($self) = @_;
          return if $self->{_registers}{'LOOP'} < 0;
          $self->{_registers}{'MP'}++;
          $self->{_registers}{'PP'}++;
      },
      '<' => sub {
          my ($self) = @_;
          return if $self->{_registers}{'LOOP'} < 0;
          $self->{_registers}{'MP'}--;
          $self->{_registers}{'PP'}++;
      },
      '[' => sub {
          my ($self) = @_;
          if ($self->{_memory}[$self->{_registers}{'MP'}] > 0) {
              push @{ $self->{_stack} }, $self->{_registers}{'PP'};
          } else {
              $self->{_registers}{'LOOP'}--;
          }
          $self->{_registers}{'PP'}++;
          return;
      },
      ']' => sub {
          my ($self) = @_;
          my $loop_stacktart = pop @{ $self->{_stack} };
          if ($self->{_memory}[$self->{_registers}{'MP'}]) {
              $self->{_registers}{'PP'} = $loop_stacktart;
          } else {
              $self->{_registers}{'PP'}++;
          }
          $self->{_registers}{'LOOP'}++;
      },
  );

  sub new {
      my $class = shift;
      my $data = {
          _registers => { map { $_ => 0 } @REGISTERS },
          _memory => [],
          _stack => [],
          _output => [],
      };
      bless $data, $class;
  };

  sub run {
      my $self = shift;
      while ($self->{_registers}{PP} < $self->{_max_program_size}) {
          my $op_char = $self->{_program}[$self->{_registers}{PP}];
          my $op = $OPERATORS{$op_char};
          $op->($self);
      }
  }

  sub set_memory {
      my ($self, $memory) = @_;
      $self->{_program} = [ split //, $memory ];
      $self->{_max_program_size} = @{ $self->{_program} };
  }

  sub output {
      my $self = shift;
      return join ',', @{ $self->{_output} };
  }

  sub char_output {
      my $self = shift;
      return join '', map { chr($_) } @{ $self->{_output} };
  }
}

package main;
use strict;
use warnings;

use Test::More qw(no_plan);

my %test_data = (
    '++.' => '2',
    '++-.' => '1',
    '++.>+.<+.' => '2,1,3',
    '+++.[-.].' => '3,2,1,0,0',
    '++.[->++[.-]<]' => '2,2,1,2,1',
    '++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.' => '72,101,108,108,111,32,87,111,114,108,100,33,10',
);
while (my ($prog, $exptected_output) = each %test_data) {
    my $bf = BF->new();
    $bf->set_memory($prog);
    $bf->run();
    is($bf->output(), $exptected_output, $prog);
}

my $bf = BF->new();
$bf->set_memory('++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.');
$bf->run();
is("Hello World!n", $bf->char_output(), "Hello World!");

Eine tolle sinnlose Beschäftigung.

Und wen es interessiert: Das Plakat zum Programm.