gistfile2.txt

minilang.pl

package Node;
use strict;
use warnings;

my %vars = ();

sub new {
    my $class = shift;
    my ($l, $r) = @_;
    bless { left => $l, right => $r, op => '?' }, $class;
}

sub to_s {
    my $self = shift;
    return
	'('.
	$self->to_str($self->{left}).
	$self->to_str($self->{op}).
	$self->to_str($self->{right}).
	')';
}

sub to_str {
    my $self = shift;
    my $ob = shift;

    unless(ref($ob)) {
	return $ob || '';
    } else {
	return $ob->to_s() || '';
    }
}

sub get_left { shift->{left} }
sub get_right { shift->{right} }
sub get_op { shift->{op} }


1;


package Add;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '+';
    $self;
}

sub exec {
    my $self = shift;
    return $self->{left}->exec() + $self->{right}->exec();
}

1;

package Sub;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '-';
    $self;
}

sub exec {
    my $self = shift;
    return $self->{left}->exec() - $self->{right}->exec();
}

1;

package Mul;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '*';
    $self;
}

sub exec {
    my $self = shift;
    return $self->{left}->exec() * $self->{right}->exec();
}

1;

package Div;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '/';
    $self;
}

sub exec {
    my $self = shift;
    return $self->{left}->exec() / $self->{right}->exec();
}

1;

package Mod;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '%';
    $self;
}

sub exec {
    my $self = shift;
    return $self->{left}->exec() % $self->{right}->exec();
}

1;

package Lit;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '#';
    $self;
}

sub exec {
    return shift->{left};
}

1;

package Var;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '$';
    $self;
}

sub exec {
    my $self = shift;
    return $vars{$self->{left}};
}

1;

package Assign;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '=';
    $self;
}

sub exec {
    my $self = shift;

    my $v = $self->{right}->exec();
    $vars{$self->{left}->get_left()} = $v;

    return $v;
}

1;

package Seq;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = ';';
    $self;
}

sub exec {
    my $self = shift;
    $self->{left}->exec();
    return $self->{right}->exec();
}

1;

package Loop;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'L';
    $self;
}

sub exec {
    my $self = shift;
    my $times = $self->{left}->exec();
    my $v;
    for (my $i = 0; $i < $times; $i++) {
	$v = $self->{right}->exec();
    }
    return $v;
}

1;

package Noop;
use strict;
use warnings;
use base qw/Node/;

sub new { }
sub exec { 0 }
sub to_s { '?' }

1;

package Le;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '<=';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() le $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;

package Lt;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '<';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() lt $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;

package Ge;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '>=';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() ge $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;

package Gt;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = '>';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() gt $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;


package Ne;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'ne';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() ne $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;

package Eq;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'eq';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() eq $self->{right}->exec()) {
	return 1;
    } else {
	return 0;
    }
}

1;

package If;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'I';
    $self;
}

sub exec {
    my $self = shift;
    if ($self->{left}->exec() != 0) {
	$self->{right}->exec();
    }
}

1;

package While;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'W';
    $self;
}

sub exec {
    my $self = shift;
    while ( $self->{left}->exec() != 0) {
	$self->{right}->exec();
    }
}

1;

package Read;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'R';
    $self;
}

sub exec {
    my $self = shift;
    print '> ';
    my $in = <STDIN>;
    chomp($in);
    return $in;
}

1;

package Print;
use strict;
use warnings;
use base qw/Node/;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{op} = 'P';
    $self;
}

sub exec {
    my $self = shift;
    print $self->{left}->exec(), "\n";
}

1;

package FileLexer;
use strict;
use warnings;


sub new {
    my $class = shift;
    my ($f) = @_;

    my $self = bless {}, $class;

    open my $fh, '<', $f;
    $self->{file} = $fh;

    $self->{str} = <$fh>;
    my @l;
    while ($self->{str} =~ /(.)/g) {
	push @l, $1;
    }
    $self->{line} = \@l;
    
    $self->{pos} = 0;
    $self->{lno} = 0;

    $self->{cur} = '$';

    $self->fwd();

    $self;
}

sub fwd {
    my $self = shift;

    while (@{$self->{line}}) {
	my $line_length = @{$self->{line}};
	if ($self->{pos} >= $line_length) {
	    my $fh = $self->{file};
	    my $line = <$fh>;
	    my @l = ();
	    if ($line) {
		while ($line =~ m/(.)/g) {
		    push @l, $1;
		}
	    }
	    $self->{line} = [@l];
	    $self->{pos} = 0;
	    $self->{lno} += 1;
	    next;
	}

	my $c = $self->{line}->[$self->{pos}];
	my $l = @{$self->{line}};
	if ($c eq ' ' || $c eq "\n" || $c eq "\r" || $c eq "\t") {
	    $self->{pos} += 1;
	    next;
	} elsif ($c ge '0' && $c le '9') {
	    my $p = $self->{pos} + 1;
	    while ($p < $l && $self->{line}->[$p] ge '0' && $self->{line}->[$p] lt '9') {
		$p += 1;
	    }
	    $self->{cur} = '0';
	    $self->{str} = join('',@{$self->{line}}[$self->{pos}..($p-1)]); 
	    $self->{pos} = $p;
	    return;
	} elsif ($c ge 'a' && $c le 'z' || $c ge 'A' && $c le 'Z') {
	    my $p = $self->{pos} + 1;
	    while ($p < $l &&
		   ($self->{line}->[$p] ge '0' && $self->{line}->[$p] le '9' ||
		    $self->{line}->[$p] ge 'a' && $self->{line}->[$p] le 'z' ||
		    $self->{line}->[$p] ge 'A' && $self->{line}->[$p] le 'Z')) {
		$p += 1;
	    }
	    $self->{cur} = 'a';
	    $self->{str} = join('',@{$self->{line}}[$self->{pos}..($p-1)]);
	    $self->{pos} = $p;

	    if ($self->{str} eq 'while') { $self->{cur} = 'W'; }
	    elsif ($self->{str} eq 'if') { $self->{cur} = 'I'; }
	    elsif ($self->{str} eq 'print') { $self->{cur} = 'P'; }
	    elsif ($self->{str} eq 'read') { $self->{cur} = 'R'; }
	    return;
	} else {
	    $self->{cur} = $c;
	    $self->{pos} += 1;
	    if (($c eq '=' || $c eq '<' || $c eq '>' || $c eq '!') &&
		$self->{pos} < $l && $self->{line}->[$self->{pos}] eq '=') {
		$self->{cur} .= '=';
		$self->{pos} += 1;
	    }
	    return;
	}
    }
    $self->{cur} = '$';
}
				
sub peek { shift->{cur} }
sub get_str { shift->{str} }
sub to_s {
    my $self = shift;
    "line $self->{lno}: char $self->{pos} in $#{$self->{line}}" 
}

1;

package main;
use strict;
use warnings;

sub prog {
    my $sc = shift;
    my $s = state($sc);
    my $c = $sc->peek();
    if ($c eq '$' || $c eq '}') {
	return $s;
    } elsif ($c eq ';') {
	$sc->fwd();
	return Seq->new($s, prog($sc));
    } else {
	print 'STATE:'.$sc->to_s()."\n";
	return Noop->new();
    }
}

sub state {
    my $sc = shift;
    my $c = $sc->peek();

    if ($c eq '{') {
	$sc->fwd();
	my $p = prog($sc);
	if ($sc->peek() ne '}') {
	    print 'NO_}:'.$sc->to_s()."\n";
	    return Noop->new();
	}
	$sc->fwd();
	return $p;
    } elsif ($c eq 'W') {
	$sc->fwd();
	my $e = asn($sc);
	return While->new($e, state($sc));
    } elsif ($c eq 'I') {
	$sc->fwd();
	my $e = asn($sc);
	return If->new($e, state($sc));
    } elsif ($c eq 'P') {
	$sc->fwd();
	my $e = asn($sc);
	return Print->new($e);
    } else {
	return asn($sc);
    }
}

sub asn {
    my $sc = shift;
    my $e = comp($sc); 
    my $c = $sc->peek();

    if ($c eq '=') {
	$sc->fwd();
	return Assign->new($e, asn($sc));
    }
    return $e;
}

sub comp {
    my $sc = shift;

    my $e = expr($sc);
    my $c = $sc->peek();
    
    if ($c eq '<') {
	$sc->fwd();
	return Lt->new($e, comp($sc));
    } elsif ($c eq '<=') {
	$sc->fwd();
	return Le->new($e, comp($sc));
    } elsif ($c eq '>') {
	$sc->fwd();
	return Gt->new($e, comp($sc));
    } elsif ($c eq '>=') {
	$sc->fwd();
	return Ge->new($e, comp($sc));
    } elsif ($c eq '==') {
	$sc->fwd();
	my $t =Eq->new($e, comp($sc)); 
	return $t;
    } elsif ($c eq '!=') {
	$sc->fwd();
	return Ne->new($e, comp($sc));
    } else {
	return $e;
    }
}

sub expr {
    my $sc = shift;
    my $e = term($sc);
    return expr1($e, $sc);
}

sub expr1 {
    my ($e, $sc) = @_;

    my $c = $sc->peek();

    if ($c eq '+') {
	$sc->fwd();
	my $e1 = term($sc);
	return expr1(Add->new($e, $e1), $sc);
    } elsif ($c eq '-') {
	$sc->fwd();
	my $e1 = term($sc);
	return expr1(Sub->new($e, $e1), $sc);
    }

    return $e;
}

sub term {
    my $sc = shift;
    my $e = fact($sc);
    return term1($e, $sc);
}

sub term1 {
    my ($e, $sc) = @_;
    my $c = $sc->peek();

    if ($c eq '*') {
	$sc->fwd();
	my $e1 = term($sc);
	return term1(Mul->new($e, $e1), $sc);
    } elsif ($c eq '/') {
	$sc->fwd();
	my $e1 = term($sc);
	return term1(Div->new($e, $e1), $sc);
    } elsif ($c eq '%') {
	$sc->fwd();
	my $e1 = term($sc);
	return term1(Mod->new($e, $e1), $sc);
    } 
    return $e;
}

sub fact {
    my $sc = shift;
    my $c = $sc->peek();
    $sc->fwd();

    if ($c eq 'a') {
	return Var->new($sc->get_str());
    } elsif ($c eq '0') {
	return Lit->new($sc->get_str());
    } elsif ($c eq '(') {
	my $e = asn($sc);
	if ($sc->peek() ne ')') {
	    print 'NO_):'. $sc->to_s() . "\n";
	    return Noop->new();
	}
	$sc->fwd();
	return $e;
    } elsif ($c eq 'R') {
	return Read->new();
    } else {
	print 'FACTOR:' . $sc->to_s() . "\n";
	return Noop->new();
    }
}


my $e = prog(FileLexer->new($ARGV[0]));
print $e->to_s()."\n";
$e->exec();
print "\n";