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

Parse::Yapp everyday parser

関数定義可能に。ただし、変数スコープなし、グローバル

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;
@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 DefNode;
@ISA = qw(Node);

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

    $self->{ftab}     = shift;
    $self->{funcname} = shift;
    $self->{funcobj}  = shift;
    return $self;
}

sub evaluate
{
    my $self = shift;

    $self->{ftab}->{$self->{funcname}} = $self->{funcobj};
}


package FuncallNode;
@ISA = qw(Node);

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

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

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

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

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


package Function;
@ISA = qw(Node);

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

    $self->{vtable} = shift;
    $self->{fname}  = shift;
    $self->{params} = shift;
    $self->{body}   = shift;
    return $self;
}

sub call
{
    my $self = shift;
    my $args = shift;

    my $size1 = @$args;
    my $size2 = @{$self->{params}};
    if ($size1 != $size2) {
        print "wrong # of arg for $self->{fname}() ($size1 for $size2)\n";
        exit(1);
    }

    $i = 0;
    foreach my $x (@$args) {
        $self->{vtable}->{$self->{params}->[$i++]} = $x;
    }
    $self->exec_list($self->{body});
}


package 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;
@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;
@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;
@ISA = qw(Node);

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

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

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

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


package 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;
@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};
}

1;

と

%{

use Data::Dumper;
use m20080613;

my %vtable;
my %ftab;

%}

%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(\%ftab, $_[1], [$_[2]]);
               }
           | if_stmt
           | while_stmt
           | defun
;

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]);
               }
;

defun      : DEF IDENT param '\n' stmt_list END
               {
                 DefNode->new(\%ftab, $_[2],
                              Function->new(\%vtable, $_[2], $_[3], $_[5]));
               }
;

param      : '(' name_list ')'
               {
                 $_[2];
               }
           | '(' ')'
               {
                 [];
               }
           |
               {
                 [];
               }
;

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

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

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

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

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

funcall    : IDENT '(' args ')'
               {
                 FuncallNode->new(\%ftab, $_[1], $_[3]);
               }
           | IDENT '(' ')'
               {
                 FuncallNode->new(\%ftab, $_[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',
      'def'   => 'DEF',
      '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;

で、

message = "funcall ok"
print(message)
print "\n"
print message
print "\n"
print('operator', ' ok', "\n")
print('1 + 1 = ', 1+1, "\n")
print('1 + 2 * -3 = ', 1 + 2 * -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

def func
  print "defun ok\n"
end
func()
func

def argfunc(arg)
  print 'defun with arg: '
  print(arg, "\n")
end
argfunc('ok')
argfunc 'ok'

def argfunc2(arg1, arg2)
  print 'defun with arg: '
  print(arg1, " ", arg2, "\n")
end
argfunc2(1, 2)

を入力すると、

funcall ok
funcall ok
operator ok
1 + 1 = 2
1 + 2 * -3 = -5
if ok
while ok
defun ok
defun ok
defun with arg: ok
defun with arg: ok
defun with arg: 1 2
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

x = 1
def foo
  print(x, " in foo (1)\n")
  x = 2
  print(x, " in foo (2)\n")
end
print("x: ", x, "\n")
foo
print("x: ", x, "\n")

def foo(x)
  print(x, " in foo (3)\n")
end
print("x: ", x, "\n")
foo(10)
print("x: ", x, "\n")

を入力すると、

foo
foo
1 3 7 3.33333333333333
if ok
while ok
x: 1
1 in foo (1)
2 in foo (2)
x: 2
x: 2
10 in foo (3)
x: 10