File Coverage

blib/lib/Inline/SMITH.pm

Criterion	Covered	Total	%
statement	14	149	9.4
branch	2	82	2.4
condition	0	6	0.0
subroutine	4	11	36.3
pod	1	8	12.5
total	21	256	8.2

package Inline::SMITH;

$VERSION = '0.03';
require Inline;
@ISA = qw(Inline);
use strict;
use Carp;

sub register {
	return {
		language => 'SMITH',
		aliases => ['Smith', 'smith'],
		type => 'interpreted',
		suffix => 'smt',
	};
}

sub usage_config {
	my $key = shift;
	"'$key' is not a valid config option for Inline::SMITH\n";
}

sub validate {
}

sub build {
	my $o = shift;
	my $code = $o->{API}{code};
	my $pattern = $o->{ILSM}{PATTERN};
	$code = smith_load($code);
	{
		package Inline::SMITH::Loader;
		eval $code;
	}
	croak "Brainfuck build failed:\n$@" if $@;
	my $path = "$o->{API}{install_lib}/auto/$o->{API}{modpname}";
	my $obj = $o->{API}{location};
	$o->mkpath($path) unless -d $path;
	open FOO_OBJ, "> $obj" or croak "Can't open $obj for output\n$!";
	print FOO_OBJ $code;
	close \*FOO_OBJ;
}

sub load {
	my $o = shift;
	my $obj = $o->{API}{location};
	open FOO_OBJ, "< $obj" or croak "Can't open $obj for output\n$!";
	my $code = join '', ;
	close \*FOO_OBJ;
	eval "package $o->{API}{pkg};\n$code";
	croak "Unable to load Foo module $obj:\n$@" if $@;
}

sub info {
	my $o = shift;
}


sub smith_load {
	my ($code) = @_;
	my $out = "";

	while($code =~ m/function(\s+)([a-z0-9_]+)(\s*){{(.*?)}}/isg){
		my $func_name = $2;
		my $func_code = $4;
		# print "loaded function $func_name\n";
		$func_code =~ s/\|/\\|/g;
		$out .= "sub $func_name { return Inline::SMITH::smith_run(q|$func_code|, \$_[0]); }\n";
	}

	return $out;
}

sub smith_run {
	my ($code, $data) = @_;

	my $buffer = "";
	my @data;
	my $input_callback;
	my $output_callback;
	my $echo = 1;

	if (ref $data eq 'HASH'){
		@data = split(//, ${$data}{input}) if ${$data}{input};
		$input_callback = ${$data}{input_callback} || 0;
		$output_callback = ${$data}{output_callback} || 0;
		$echo = ${$data}{echo} || 0;
	}else{
		@data = split(//, $data);
	}

	my $mem = [];
	my $reg = [];
	my $debug = 0;
	my $cont = 0;
	my $quiet = 0;
	my $pause = 0;
	my ($ggg, $hhh);

	#
	# load the code into $mem
	#

	my @lines = split(/\r?\n/, $code);
	my $line = '';
	my $i = 0;
	for $line(@lines){
		$line = $' if $line =~ /^\s*/;
		$line = $` if $line =~ /\s*$/;
		$line =~ s/\s*;.*?$//;
		$line =~ s/\*/$i/ge;
		if ($line =~ /^\S+/){
			my $reps = 1;
			my $j;
			if ($line =~ /^REP\s*(\d+)\s*/){
				$line = $';
				$reps = $1;
			}
			for($j = 0; $j < $reps; $j++){
				$mem->[$i] = $line;
				# print "Load $i = $mem->[$i]\n" if $showload;
				$i++;
			}
		}
	}

	#
	# run the code
	#

	my $pc = 0;
	while($mem->[$pc] ne 'STOP') {

		if ($mem->[$pc] =~ /^MOV\s*R(\d+)\s*,\s*\#?(\d+)$/) {			# MOV reg, imm
			$reg->[$1] = $2;
		} elsif ($mem->[$pc] =~ /^MOV\s*R(\d+)\s*,\s*R(\d+)$/) {		# MOV reg, reg
			$reg->[$1] = $reg->[$2];
		} elsif ($mem->[$pc] =~ /^MOV\s*R\[R(\d+)\]\s*,\s*R(\d+)$/) {		# MOV [reg], reg
			$reg->[$reg->[$1]] = $reg->[$2];
		} elsif ($mem->[$pc] =~ /^MOV\s*R(\d+)\s*,\s*R\[R(\d+)\]$/) {		# MOV reg, [reg]
			$reg->[$1] = $reg->[$reg->[$2]];
		} elsif ($mem->[$pc] =~ /^MOV\s*R\[R(\d+)\]\s*,\s*\"(.*?)\"$/) {	# MOV [reg], "string"
			my $i = $reg->[$1];
			my $s = $2;
			while($i < ($reg->[$1] + length($s))) {
				$reg->[$i] = ord(substr($s, ($i-$reg->[$1]), 1));
				$i++;
			}
		} elsif ($mem->[$pc] =~ /^MOV\s*R(\d+)\s*,\s*PC$/) {			# MOV reg, PC
			$reg->[$1] = $pc;
		} elsif ($mem->[$pc] =~ /^MOV\s*TTY\s*,\s*R(\d+)$/) {			# MOV TTY, reg
			print chr($reg->[$1]) if $echo;
			$buffer .= chr($reg->[$1]);
			&{$output_callback}(chr($reg->[$1])) if $output_callback;
		} elsif ($mem->[$pc] =~ /^MOV\s*TTY\s*,\s*R\[R(\d+)\]$/) {		# MOV TTY, [reg]
			print chr($reg->[$reg->[$1]]) if $echo;
			$buffer .= chr($reg->[$reg->[$1]]);
			&{$output_callback}(chr($reg->[$reg->[$1]])) if $output_callback;
		} elsif ($mem->[$pc] =~ /^MOV\s*R(\d+)\s*,\s*TTY$/) {			# MOV reg, TTY
			$reg->[$1] = ($input_callback)?&{$input_callback}:shift @data;
			if ($reg->[$1]) {
				$reg->[$1] = ord($reg->[$1]);
			} else {
				$reg->[$1] = 0;
			}
		} elsif ($mem->[$pc] =~ /^MOV\s*R\[R(\d+)\]\s*,\s*TTY$/) {		# MOV [reg], TTY
			$reg->[$reg->[$1]] = ($input_callback)?&{$input_callback}:shift @data;
			if ($reg->[$reg->[$1]]) {
				$reg->[$reg->[$1]] = ord($reg->[$reg->[$1]]);
			} else {
				$reg->[$reg->[$1]] = 0;
			}
		} elsif ($mem->[$pc] =~ /^SUB\s*R(\d+)\s*,\s*\#?(\d+)$/) {		# SUB reg, imm
			$reg->[$1] -= $2;
		} elsif ($mem->[$pc] =~ /^SUB\s*R(\d+)\s*,\s*R(\d+)$/) {		# SUB reg, reg
			$reg->[$1] -= $reg->[$2];
		} elsif ($mem->[$pc] =~ /^MUL\s*R(\d+)\s*,\s*\#?(\d+)$/) {		# MUL reg, imm
			$reg->[$1] *= $2;
		} elsif ($mem->[$pc] =~ /^MUL\s*R(\d+)\s*,\s*R(\d+)$/) {		# MUL reg, reg
			$reg->[$1] *= $reg->[$2];
		} elsif ($mem->[$pc] =~ /^NOT\s*R(\d+)$/) {				# NOT reg
			if($reg->[$1] != 0) {
				$reg->[$1] = 0;
			} else {
				$reg->[$1] = 1;
			}
		} elsif ($mem->[$pc] =~ /^COR\s*([-+]\d+)\s*,\s*([-+]\d+)\s*,\s*R(\d+)\s*$/) {		# COR imm, imm, reg
			my $dst = 0+$pc+$1;
			my $src = 0+$pc+$2;
			my $lrg = 0+$3;
			my $i;
			{
				for ($i = 0; $i < $reg->[$lrg]; $i++) {
					$mem->[$dst+$i] = $mem->[$src+$i];
					$ggg = $dst + $i;
					$hhh = $src + $i;
				}
			}
		} elsif ($mem->[$pc] =~ /^COR\s*([-+]\d+)\s*,\s*R(\d+)\s*,\s*R(\d+)\s*$/) {		# COR imm, reg, reg
			my $dst = 0+$pc+$1;
			my $src = 0+$pc+$reg->[$2];
			my $lrg = 0+$3;
			my $i;
			{
				for ($i = 0; $i < $reg->[$lrg]; $i++) {
					$mem->[$dst+$i] = $mem->[$src+$i];
					$ggg = $dst + $i;
					$hhh = $src + $i;
				}
			}
		} elsif ($mem->[$pc] =~ /^BLA\s*([-+]\d+)\s*,\s*(\w+)\s*,\s*R(\d+)\s*$/) {		# BLA imm, OPC, reg
			my $dst = 0+$pc+$1;
			my $src = $2;
			my $lrg = 0+$3;
			my $i;
			{
				for ($i = 0; $i < $reg->[$lrg]; $i++) {
					$mem->[$dst+$i] = $src;
					$ggg = $dst + $i;
				}
			}
		} elsif ($mem->[$pc] =~ /^NOP$/) {						# NOP
			# Nothing happens here.
		} else {
			print "Invalid instruction $mem->[$pc]!\n";
			$pc = $#{$mem} + 1 if not $cont;
		}
		$pc++;
		$mem->[$pc] = 'STOP' if $pc > $#{$mem};
	}

	#
	# we're done
	#

	return $buffer;
}

1;

__END__