『Rubyを256倍使うための本 無道編』の 13.defun/intp.y を移植(Perl 版)
関数定義可能に。ただし、変数スコープなし、グローバル
%{
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;
@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};
@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};
}
package main;
%}
%token IDENT NUMBER STRING
%token EOL IF ELSE WHILE THEN DO END DEF
%left '+' '-'
%left '*' '/'
%left UMINUS
%%
program : stmt_list
{
program = RootNode->new(stmt_list);
return program;
}
;
r@stmt_list :
{
r = [];
}
| stmt_list stmt EOL
{
push(@{r}, stmt);
}
| stmt_list EOL
;
stmt : expr
| assign
| IDENT realprim
{
stmt = FuncallNode->new(\%ftab, IDENT, [realprim]);
}
| if_stmt
| while_stmt
| defun
;
if_stmt : IF stmt THEN EOL stmt_list else_stmt END
{
if_stmt = IfNode->new(stmt, stmt_list, else_stmt)
}
;
else_stmt : ELSE EOL stmt_list
{
else_stmt = stmt_list;
}
|
{
else_stmt = undef;
}
;
while_stmt : WHILE stmt DO EOL stmt_list END
{
while_stmt = WhileNode->new(stmt, stmt_list);
}
;
defun : DEF IDENT param EOL stmt_list END
{
defun = DefNode->new(\%ftab, IDENT,
Function->new(\%vtable, IDENT, param, stmt_list));
}
;
param : '(' name_list ')'
{
param = name_list;
}
| '(' ')'
{
param = [];
}
|
{
param = [];
}
;
r@name_list : IDENT
{
name_list = [ IDENT ];
}
| a@name_list ',' IDENT
{
push(@{r}, IDENT);
}
;
assign : IDENT '=' expr
{
assign = AssignNode->new(\%vtable, IDENT, expr);
}
;
result@expr : a@expr '+' b@expr
{
result = FuncallNode->new(\%ftab, '+', [a, b]);
}
| a@expr '-' b@expr
{
result = FuncallNode->new(\%ftab, '-', [a, b]);
}
| a@expr '*' b@expr
{
result = FuncallNode->new(\%ftab, '*', [a, b]);
}
| a@expr '/' b@expr
{
result = FuncallNode->new(\%ftab, '/', [a, b]);
}
| primary
;
result@primary : realprim
| '(' expr ')'
{
result = expr;
}
| '-' a@primary %prec UMINUS
{
result = FuncallNode->new(\%ftab, '-', [LiteralNode->new(0), a]);
}
;
realprim : IDENT
{
realprim = VarRefNode->new(\%vtable, \%ftab, IDENT);
}
| NUMBER
{
realprim = LiteralNode->new(NUMBER);
}
| STRING
{
realprim = StringNode->new(STRING);
}
| funcall
;
funcall : IDENT '(' args ')'
{
funcall = FuncallNode->new(\%ftab, IDENT, args);
}
| IDENT '(' ')'
{
funcall = FuncallNode->new(\%ftab, IDENT, []);
}
;
r@args : expr
{
r = [expr];
}
| a@args ',' expr
{
push(@{r}, expr);
}
;
%%
$lexbuf = '';
%vtable;
%ftab;
$lineno = 1;
%reserved = (
'if' => $IF,
'else' => $ELSE,
'while' => $WHILE,
'then' => $THEN,
'do' => $DO,
'def' => $DEF,
'end' => $END
);
sub yylex
{
while (1) {
if ($lexbuf =~ /^([\t ]+)/) {
$lexbuf = substr($lexbuf, length($1));
}
last if ($lexbuf ne '');
if (!($lexbuf = <>)) {
return 0;
}
}
if ($lexbuf =~ /^(\d+)/) {
$yylval = $1 - 0;
$lexbuf = substr($lexbuf, length($1));
return $NUMBER;
} elsif ($lexbuf =~ /^([a-zA-Z_]\w*)/) {
$yylval = $1;
$lexbuf = substr($lexbuf, length($1));
if (exists($reserved{$yylval})) {
return $reserved{$yylval};
} else {
return $IDENT;
}
} elsif ($lexbuf =~ /^"(?:[^"\\]+|\\.)*"/ ||
$lexbuf =~ /^'(?:[^'\\]+|\\.)*'/) {
$yylval = $&;
$lexbuf = substr($lexbuf, length($&));
return $STRING;
} else {
my $ret = ord($lexbuf);
$lexbuf = substr($lexbuf, 1);
if ($ret eq ord("\n")) {
$lineno++;
return $EOL;
} else {
return $ret;
}
}
}
sub yyerror
{
my ($msg) = @_;
print "$ARGV:$lineno: $msg\n";
}
$tree = &yyparse();
#print "* tree\n", Dumper($tree);
$tree->evaluate();で、
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
