『Rubyを256倍使うための本 無道編』の 12.if_while/intp.y を移植

%{

use Data::Dumper;


package Node;

sub new
{
    my $class = shift;
    bless {}, $class;
}

sub exec_list
{
    my $self = shift;
    my ($nodes) = @_;

    foreach my $i (@$nodes) {
        $i->evaluate();
    }
}


package RootNode;
@RootNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{tree} = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    $self->exec_list($self->{tree});
}


package FuncallNode;
@FuncallNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{func} = shift;
    $self->{args} = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;
    my $args = $self->{args};

    my @arg = map { $_->evaluate() } @$args;

    if ($self->{func} =~ /^[+*\/-]$/) {
        eval $arg[0] . $self->{func} . "$arg[1];";
    } else {
        my $cmd = "$self->{func}(" . join(",", @arg) . ");";
        eval $cmd;
    }
}


package IfNode;
@IfNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{condition} = shift;
    $self->{tstmt}     = shift;
    $self->{fstmt}     = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    if ($self->{condition}->evaluate()) {
        $self->exec_list($self->{tstmt});
    } else {
        $self->exec_list($self->{fstmt});
    }
}


package WhileNode;
@WhileNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{condition} = shift;
    $self->{body}      = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    while ($self->{condition}->evaluate()) {
        $self->exec_list($self->{body});
    }
}


package AssignNode;
@AssignNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{vtable} = shift;
    $self->{vname}  = shift;
    $self->{val}    = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    $self->{vtable}->{$self->{vname}} = $self->{val}->evaluate();
}


package VarRefNode;
@VarRefNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{vtable} = shift;
    $self->{vname}  = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;
    my $vtable = $self->{vtable};

    if (exists($vtable->{$self->{vname}})) {
        $vtable->{$self->{vname}};
    } else {
        eval $vtable->{$self->{vname}};
        if ($@) {
            print "unknown method or local variable $self->{vname}\n";
        }
    }
}


package StringNode;
@StringNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{val} = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    $self->{val};
}


package LiteralNode;
@LiteralNode::ISA = qw(Node);

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new();
    bless $self, $class;

    $self->{val} = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    $self->{val};
}


package IntpParser;

my %vtable;

%}

%left   '+' '-'
%left   '*' '/'
%left   UMINUS

%%

program    : stmt_list
               {
                 RootNode->new($_[1]);
               }
;

stmt_list  :
               {
                 []
               }
           | stmt_list stmt '\n'
               {
                 $_[0]->YYData->{LINENO}++;
                 push(@{$_[1]}, $_[2]); $_[1]
               }
           | stmt_list '\n'
               {
                 $_[0]->YYData->{LINENO}++;
                 $_[1];
               }
           | error      '\n' { $_[0]->YYErrok }
;

stmt       : expr
           | assign
           | IDENT realprim
               {
                 FuncallNode->new($_[1], [$_[2]]);
               }
           | if_stmt
           | while_stmt
;

if_stmt    : IF stmt THEN '\n' stmt_list else_stmt END
               {
                 IfNode->new($_[2], $_[5], $_[6]);
               }
;

else_stmt  : ELSE '\n' stmt_list
               {
                 $_[3];
               }
           |
               {
                 undef;
               }
;

while_stmt : WHILE stmt DO '\n' stmt_list END
               {
                 WhileNode->new($_[2], $_[5]);
               }
;

assign     : IDENT '=' expr
               {
                 AssignNode->new(\%vtable, $_[1], $_[3]);
               }
;

expr       : expr '+' expr  { FuncallNode->new('+', [$_[1], $_[3]]); }
           | expr '-' expr  { FuncallNode->new('-', [$_[1], $_[3]]); }
           | expr '*' expr  { FuncallNode->new('*', [$_[1], $_[3]]); }
           | expr '/' expr  { FuncallNode->new('/', [$_[1], $_[3]]); }
           | primary
;

primary    : realprim
           | '(' expr ')'             { $_[2] }
           | '-' primary %prec UMINUS { FuncallNode->new('-', [LiteralNode->new(0), $_[2]]) }
;

realprim   : IDENT    { VarRefNode->new(\%vtable, $_[1]); }
           | NUMBER   { LiteralNode->new($_[1]);          }
           | STRING   { StringNode->new($_[1]);           }
           | funcall
;

funcall    : IDENT '(' args ')'
               {
                 FuncallNode->new($_[1], $_[3]);
               }
           | IDENT '(' ')'
               {
                 FuncallNode->new($_[1], []);
               }
;

args       : expr
               {
                 [$_[1]];
               }
           | args ',' expr
               {
                 push(@{$_[1]}, $_[3]); $_[1]
               }
;

%%

sub _Error {
        exists $_[0]->YYData->{ERRMSG}
    and do {
        print  $_[0]->YYData->{ERRMSG};
        delete $_[0]->YYData->{ERRMSG};
        return;
    };
    print "$ARGV:$_[0]->YYData->{LINENO} Syntax error.\n";
}

sub _Lexer {
    my($parser) = shift;

    my(%reserved) = (
      'if'    => 'IF',
      'else'  => 'ELSE',
      'while' => 'WHILE',
      'then'  => 'THEN',
      'do'    => 'DO',
      'end'   => 'END'
    );

        $parser->YYData->{INPUT}
    or  $parser->YYData->{INPUT} = <>
    or  return('',undef);

    $parser->YYData->{INPUT} =~ s/^[ \t]+//;

    for ($parser->YYData->{INPUT}) {
        s/^(\d+)//
                and return('NUMBER', $1);
        if (s/^([a-zA-Z_]\w*)//) {
            my $sym = $1;
            if (exists($reserved{$sym})) {
                return($reserved{$sym}, $sym);
            } else {
                return('IDENT', $sym);
            }
        }
        (s/^"(?:[^"\\]+|\\.)*"// ||
         s/^'(?:[^'\\]+|\\.)*'//)
                and return('STRING', $&);
        s/^(.)//s
                and return($1, $1);
    }
}

sub Run {
    my($self) = shift;

    $self->YYData->{LINENO} = 1;
    my($tree) = $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error );
    #print "* tree\n", Dumper($tree);
    $tree->evaluate();
}

my($parser) = new IntpParser;
$parser->Run;

で、

print "foo\n"
print("foo\n")
print(1, " ", 1+2, " ", 1+2*3, " ", 10/3, "\n")

if 1 then
  print "if ok\n"
else
  print "if not ok\n"
end

i = 1
while i do
  print "while ok\n"
  i = 0
end

を入力すると、

foo
foo
1 3 7 3.33333333333333
if ok
while ok