MyBF - Interpretador de BrainFuck

Descrição

Esconder código-fonte

#!/usr/bin/perl -w

# Author: Danillo Souza
# Email:  danillo012@gmail.com
# Version: 0.1
#
# This script implements the original syntax of BrainF*ck, with few modifications,
# only two additional commands actually. The first is the '!' serving
# to write the value of the current cell as an integer, and the second is '$'
# used to read a number (actually, one digit) and store your value in the current cell.
# 
# If you extend this script with new functionalities, please send me the
# changes via email. I would be happy if I saw someone improving this little
# interpreter and adding new stuff.
# 
# And do not forget. if you extend this interpreter, do not use modules not
# are patterns of Perl. The goal is to ensure that the interpreter is 100% portable,
# not force people to install new modules.

use strict;
use diagnostics;

# Opening file
die "Usage: mybf.pl <scriptfile>\n" if scalar(@ARGV) < 1;
open my $file, '<', $ARGV[0] or die "Can't open file.\n";

# Variables
my $top = 30000;
my $ptr = 0;
my $cou = 0;
my $src = '';
my @segment = (1..$top); foreach (@segment){$_ = 0;}
my @loops = ();

# Getting the source code
while (<$file>) {$src .= $_;}
close($file);

# Eliminating non-bf characters
$src =~ s/[^\+\-\.\!\[\],\$<>]//g;

# Verifying the brackets equivalency
my $lbrackets = scalar(grep(/[\[]/g, $src));
my $rbrackets = scalar(grep(/[\]]/g, $src));
print "Missing brackets -> ([: $lbrackets | ]: $lbrackets)\n" if ($lbrackets != $rbrackets);

# Execution loop
while ($cou < length($src)) {
   my $ch = substr($src, $cou, 1);$cou++;
   if ($ch eq '>') {$ptr++;if ($ptr>256){$ptr=0}}
   if ($ch eq '<') {$ptr--;if ($ptr<0){$ptr=256}}
   if ($ch eq '+') {$segment[$ptr]++}
   if ($ch eq '-') {$segment[$ptr]--}
   if ($ch eq '.') {print chr($segment[$ptr]);}
   if ($ch eq '!') {print int($segment[$ptr]);}
   if ($ch eq ',') {my $y=<STDIN>;$segment[$ptr]=ord(substr($y,0,1));}
   if ($ch eq '$') {my $y=<STDIN>;$segment[$ptr]=int(substr($y,0,1));}
   if ($ch eq '[') {push(@loops, $cou)}
   if ($ch eq ']') {if ($segment[$ptr]!=0){$cou=$loops[$#loops]}else{pop(@loops)}}
}