in reply to Implementing a toy language in perl?
Here's an example for you. It implements a very simple language, see the examples/testcases in the DATA section.
It uses a modified Pratt parser (sort of, maybe) to build a parse tree (Abstract Syntax Tree) in perl objects.
It then prints the tree
(in indent style).
Finally it runs the tree (using perl's polymorphism) by sending the "v" method to the top node of the tree.
It hasn't been extensively tested, so there may be a bug or two, but that's part of the fun, isn't it?
I hope this complete running example helps...
#!/usr/bin/perl
# toylanguage.pl - a toy language for an example (by tybalt89)
# perl'ified https://en.wikipedia.org/wiki/Pratt_parser
# see __DATA__ section for examples of the language
use strict;
use warnings;
my %memory;
my ($running, $hasprint); # various flags
my $ws = qr/(?:#.*|\s+)*+/; # white space
my $aws = qr/(?:#.*|\s+)++/; # actual white space
sub err
{
exit print "\n**ERROR** ", $running ? "@_" : s/\G/<** @_ **>/r, "\n"
}
sub getlist # for print and call
{
my @list = expr(5);
push @list, expr(5) while /\G$ws , /gcx;
return @list;
}
sub namelist # for formal parameter names
{
my @list;
$1 eq 'as' ? return @list : push @list, $1
while /\G$ws ([a-z]\w*)\b /gcxi;
err 'missing "as"';
}
sub node { bless [ @_[1..$#_] ], $_[0] }
sub closeparen { /\G$ws\)/gc ? shift : err 'missing )' }
sub expr # the parser :)
{
/\G$aws/gc;
my $tree =
/\G - /gcx ? node NEG => expr(12) : # unary minus
/\G \+ /gcx ? +expr(12) : # unary plus
/\G \( /gcx ? closeparen expr(0) :
/\G ((?:\d+(?:\.\d*)?|\.\d+)(?:[Ee][+-]?\d+\b)?) /gcx ? node NUM =
+> $1 :
/\G print\b /gcx ? ($hasprint++, node PRINT => getlist) :
/\G for\b /gcx ? node FOR =>
/\G$ws ([a-z]\w*)\b /gcxi ? "$1" : err('missing name'),
/\G$ws from\b /gcx ? expr(2) : err('missing "from"'),
/\G$ws to\b /gcx ? expr(2) : err('missing "to"'),
/\G$ws do\b /gcx ? expr(2) : err('missing "do"'), :
/\G while\b /gcx ? node NWHILE => expr(3),
/\G$ws do\b /gcx ? expr(2) : err 'missing "do"' :
/\G ([a-z]\w*)\b /gcx ? do { my $name = $1; /\G$aws/gc;
/\G =(?!=) /gcxi ? node STORE => $name, expr(5) :
/\G with\b /gcxi ? $memory{$name} =
node LAMBDA => node(PARAMS => namelist), expr(2) :
/\G as\b /gcxi ? $memory{$name} =
node LAMBDA => node('PARAMS'), expr(2) :
/\G \( /gcxi ? closeparen node CALL => $name,
node(ARGS => /\G$ws (?= \) ) /gcx ? () : getlist) :
node FETCH => $name } :
err 'bad operand';
# precedences: (12 **) (11 * /) (10 + -) (9 < > <= >=) (8 == !=)
# (7 &&) (6 ||) (5 ?) (4 and) (3 or) (2 while) (1 ;)
/\G$aws/gc, $tree =
/\G \*\* /gcx ? node POW => $tree, expr(12) :
$_[0] > 11 ? return $tree :
/\G \* /gcx ? node MUL => $tree, expr(12) :
/\G \/ /gcx ? node DIV => $tree, expr(12) :
$_[0] > 10 ? return $tree :
/\G \+ /gcx ? node ADD => $tree, expr(11) :
/\G - /gcx ? node SUB => $tree, expr(11) :
$_[0] > 9 ? return $tree :
/\G >= /gcx ? node GE => $tree, expr(10) :
/\G > /gcx ? node GT => $tree, expr(10) :
/\G <= /gcx ? node LE => $tree, expr(10) :
/\G < /gcx ? node LT => $tree, expr(10) :
$_[0] > 8 ? return $tree :
/\G == /gcx ? node EQ => $tree, expr(9) :
/\G != /gcx ? node NE => $tree, expr(9) :
$_[0] > 7 ? return $tree :
/\G && /gcx ? node AND => $tree, expr(8) :
$_[0] > 6 ? return $tree :
/\G \|\| /gcx ? node OR => $tree, expr(7) :
$_[0] > 5 ? return $tree :
/\G \? /gcx ? node COND => $tree, expr(5),
/\G$ws : /gcx ? expr(5) : err 'missing :' :
$_[0] > 4 ? return $tree :
/\G and\b /gcx ? node AND => $tree, expr(5) :
$_[0] > 3 ? return $tree :
/\G or\b /gcx ? node OR => $tree, expr(4) :
$_[0] > 2 ? return $tree :
/\G while\b /gcx ? node WHILE => $tree, expr(3) :
$_[0] > 1 ? return $tree :
/\G ; /gcx ? ( /\G$ws(?= ; | \) | \z )/gcx ? $tree :
node STMT => ref $tree eq 'STMT' ? @$tree : $tree, expr(2) ) :
return $tree while 1;
}
# control section
for ( @ARGV ? @ARGV : grep /\S/, split /^__END__\n/m, join '', <DATA>
+)
{
eval { $hasprint = $running = %memory = ();
my $tree = expr(0);
/\G$ws \z /gcx or err("incomplete parse");
print "\n", s/\s*\z/\n/r;
showtree( $tree, 0 ); # uncomment to see AST
$running++;
my $answer = $tree->v;
$hasprint or print "= $answer\n";
1
} or err($@);
}
sub showtree
{
my ($t, $i) = @_;
print '. ' x $i, ref $t eq 'NUM' ? $t->[0] : ref $t || $t, "\n";
showtree( $_, $i + 1 ) for ref $t && ref $t ne 'NUM' ? @$t : ();
}
# interpreter section
sub ADD::v { $_[0][0]->v + $_[0][1]->v }
sub SUB::v { $_[0][0]->v - $_[0][1]->v }
sub MUL::v { $_[0][0]->v * $_[0][1]->v }
sub DIV::v { $_[0][0]->v / $_[0][1]->v }
sub POW::v { $_[0][0]->v ** $_[0][1]->v }
sub AND::v { $_[0][0]->v and $_[0][1]->v }
sub OR::v { $_[0][0]->v or $_[0][1]->v }
sub NUM::v { $_[0][0] }
sub NEG::v { -$_[0][0]->v }
sub GT::v { $_[0][0]->v > $_[0][1]->v or 0 }
sub GE::v { $_[0][0]->v >= $_[0][1]->v or 0 }
sub LE::v { $_[0][0]->v <= $_[0][1]->v or 0 }
sub LT::v { $_[0][0]->v < $_[0][1]->v or 0 }
sub EQ::v { $_[0][0]->v == $_[0][1]->v or 0 }
sub NE::v { $_[0][0]->v != $_[0][1]->v or 0 }
sub COND::v { $_[0][0]->v ? $_[0][1]->v : $_[0][2]->v }
sub FETCH::v { $memory{$_[0][0]} // err(" variable $_[0][0] never set"
+) }
sub STORE::v { $memory{$_[0][0]} = $_[0][1]->v }
sub PRINT::v { my $t = 0; print "> @{[ map $t = $_->v, @{ $_[0] } ]}\n
+"; $t }
sub WHILE::v { $_[0][0]->v while $_[0][1]->v; 0 }
sub NWHILE::v { $_[0][1]->v while $_[0][0]->v; 0 }
sub STMT::v { my $t = 0; $t = $_->v for @{ $_[0] }; $t}
sub FOR::v { my ($t, $s, $e, $n) = (0, $_[0][1]->v, $_[0][2]->v, $_[0]
+[0]);
local $memory{$n};
for my $i ($s..$e){$memory{$n} = $i; $t = $_[0][3]->v} $t }
sub CALL::v { ref $memory{$_[0][0]} or err("$_[0][0] not a function");
$memory{$_[0][0]}->call( map $_->v, @{ $_[0][1] } ) }
sub LAMBDA::call { my @params = @{ $_[0][0] };
@params and local @memory{@params} = @_[1..$#_]; $_[0][1]->v }
sub LAMBDA::v { 0 }
__DATA__
123 * 456
__END__
2 + 3 * 4
__END__
2 * 3 + 4
__END__
-2**3
__END__
2 > 5 ? 3 : 4
__END__
print 40 + 2
__END__
foo = 12 ; print foo, foo + foo * 3, -1 ; 0
__END__
factorial with n as n > 1 ? n * factorial(n - 1) : 1;
print 5, factorial(5)
__END__
# classic factorial
factorial with n as n > 1 ? n * factorial(n - 1) : 1;
for n from 0 to 10 do print n, factorial(n);
__END__
# towers
tower(3, 1, 2, 3);
tower with n from to spare as
n > 0 and
(
tower( n - 1, from, spare, to );
print n, from, to;
tower( n - 1, spare, to, from );
)
__END__
foo = 5; foo = -1 + print foo while foo > 0;
__END__
qwe = 7; while qwe > 3 do ( print qwe; qwe = qwe - 1; 41; 42 );;;
__END__
Re^2: Implementing a toy language in perl?
by tybalt89 (Monsignor) on Sep 21, 2016 at 22:10 UTC
|
Oops, there is a /i in the wrong place(s).
#!/usr/bin/perl
# toylanguage.pl - a toy language for an example (by tybalt89)
# perl'ified https://en.wikipedia.org/wiki/Pratt_parser
# see __DATA__ section for examples of the language
use strict;
use warnings;
my %memory;
my ($running, $hasprint); # various flags
my $ws = qr/(?:#.*|\s+)*+/; # white space
my $aws = qr/(?:#.*|\s+)++/; # actual white space
sub err
{
exit print "\n**ERROR** ", $running ? "@_" : s/\G/<** @_ **>/r, "\n"
}
sub getlist # for print and call
{
my @list = expr(5);
push @list, expr(5) while /\G$ws , /gcx;
return @list;
}
sub namelist # for formal parameter names
{
my @list;
$1 eq 'as' ? return @list : push @list, $1
while /\G$ws ([a-z]\w*)\b /gcxi;
err 'missing "as"';
}
sub node { bless [ @_[1..$#_] ], $_[0] }
sub closeparen { /\G$ws\)/gc ? shift : err 'missing )' }
sub expr # the parser :)
{
/\G$aws/gc;
my $tree =
/\G - /gcx ? node NEG => expr(12) : # unary minus
/\G \+ /gcx ? +expr(12) : # unary plus
/\G \( /gcx ? closeparen expr(0) :
/\G ((?:\d+(?:\.\d*)?|\.\d+)(?:[Ee][+-]?\d+\b)?) /gcx ? node NUM =
+> $1 :
/\G print\b /gcx ? ($hasprint++, node PRINT => getlist) :
/\G sqrt\b $ws \( /gcx ? closeparen node SQRT => expr(5) :
/\G for\b /gcx ? node FOR =>
/\G$ws ([a-z]\w*)\b /gcxi ? "$1" : err('missing name'),
/\G$ws from\b /gcx ? expr(2) : node(NUM => 1),
/\G$ws to\b /gcx ? expr(2) : err('missing "to"'),
/\G$ws by\b /gcx ? expr(2) : node(NUM => 1),
/\G$ws do\b /gcx ? expr(2) : err('missing "do"'), :
/\G while\b /gcx ? node NWHILE => expr(3),
/\G$ws do\b /gcx ? expr(2) : err 'missing "do"' :
/\G ([a-z]\w*)\b /gcxi ? do { my $name = $1; /\G$aws/gc;
/\G =(?!=) /gcx ? node STORE => $name, expr(5) :
/\G with\b /gcx ? $memory{$name} =
node LAMBDA => $name, node(PARAMS => namelist), expr(2) :
/\G as\b /gcx ? $memory{$name} =
node LAMBDA => $name, node('PARAMS'), expr(2) :
/\G \( /gcx ? closeparen node CALL => $name,
node(ARGS => /\G$ws (?= \) ) /gcx ? () : getlist) :
node FETCH => $name } :
err 'bad operand';
# precedences: (12 **) (11 * /) (10 + -) (9 < > <= >=) (8 == !=)
# (7 &&) (6 ||) (5 ?) (4 and) (3 or) (2 while) (1 ;)
/\G$aws/gc, $tree =
/\G \*\* /gcx ? node POW => $tree, expr(12) :
$_[0] > 11 ? return $tree :
/\G \* /gcx ? node MUL => $tree, expr(12) :
/\G \/ /gcx ? node DIV => $tree, expr(12) :
$_[0] > 10 ? return $tree :
/\G \+ /gcx ? node ADD => $tree, expr(11) :
/\G - /gcx ? node SUB => $tree, expr(11) :
$_[0] > 9 ? return $tree :
/\G >= /gcx ? node GE => $tree, expr(10) :
/\G > /gcx ? node GT => $tree, expr(10) :
/\G <= /gcx ? node LE => $tree, expr(10) :
/\G < /gcx ? node LT => $tree, expr(10) :
$_[0] > 8 ? return $tree :
/\G == /gcx ? node EQ => $tree, expr(9) :
/\G != /gcx ? node NE => $tree, expr(9) :
$_[0] > 7 ? return $tree :
/\G && /gcx ? node AND => $tree, expr(8) :
$_[0] > 6 ? return $tree :
/\G \|\| /gcx ? node OR => $tree, expr(7) :
$_[0] > 5 ? return $tree :
/\G \? /gcx ? node COND => $tree, expr(5),
/\G$ws : /gcx ? expr(5) : err 'missing :' :
$_[0] > 4 ? return $tree :
/\G and\b /gcx ? node AND => $tree, expr(5) :
$_[0] > 3 ? return $tree :
/\G or\b /gcx ? node OR => $tree, expr(4) :
$_[0] > 2 ? return $tree :
/\G while\b /gcx ? node WHILE => $tree, expr(3) :
$_[0] > 1 ? return $tree :
/\G ; (?= $ws (?: ; | \) | \z ) ) /gcx ? $tree :
/\G ; /gcx ? node STMT => ref $tree eq 'STMT' ? @$tree : $tree, ex
+pr(2) :
return $tree while 1;
}
# control section
for ( @ARGV ? @ARGV : grep /\S/, split /^__END__\n/m, join '', <DATA>
+)
{
eval { $hasprint = $running = %memory = ();
my $tree = expr(0);
/\G$ws \z /gcx or err("incomplete parse");
print "\n", s/\s*\z/\n/r;
showtree( $tree, 0 ); # uncomment to see AST
$running++;
my $answer = $tree->v;
$hasprint or print "= $answer\n";
1
} or err($@);
}
sub showtree
{
my ($t, $i) = @_;
print '. ' x $i, ref $t eq 'NUM' ? $t->[0] : ref $t || $t, "\n";
showtree( $_, $i + 1 ) for ref $t && ref $t ne 'NUM' ? @$t : ();
}
# interpreter section
sub ADD::v { $_[0][0]->v + $_[0][1]->v }
sub SUB::v { $_[0][0]->v - $_[0][1]->v }
sub MUL::v { $_[0][0]->v * $_[0][1]->v }
sub DIV::v { $_[0][0]->v / $_[0][1]->v }
sub POW::v { $_[0][0]->v ** $_[0][1]->v }
sub AND::v { $_[0][0]->v and $_[0][1]->v }
sub OR::v { $_[0][0]->v or $_[0][1]->v }
sub NUM::v { $_[0][0] }
sub NEG::v { -$_[0][0]->v }
sub GT::v { $_[0][0]->v > $_[0][1]->v or 0 }
sub GE::v { $_[0][0]->v >= $_[0][1]->v or 0 }
sub LE::v { $_[0][0]->v <= $_[0][1]->v or 0 }
sub LT::v { $_[0][0]->v < $_[0][1]->v or 0 }
sub EQ::v { $_[0][0]->v == $_[0][1]->v or 0 }
sub NE::v { $_[0][0]->v != $_[0][1]->v or 0 }
sub COND::v { $_[0][0]->v ? $_[0][1]->v : $_[0][2]->v }
sub FETCH::v { $memory{$_[0][0]} // err(" variable $_[0][0] never set"
+) }
sub STORE::v { $memory{$_[0][0]} = $_[0][1]->v }
sub PRINT::v { my $t = 0; print "> @{[ map $t = $_->v, @{ $_[0] } ]}\n
+"; $t }
sub SQRT::v { sqrt $_[0][0]->v }
sub WHILE::v { $_[0][0]->v while $_[0][1]->v; 0 }
sub NWHILE::v { $_[0][1]->v while $_[0][0]->v; 0 }
sub STMT::v { my $t = 0; $t = $_->v for @{ $_[0] }; $t}
sub FOR::v { my ($t, $s, $e, $b, $n) =
(0, $_[0][1]->v, $_[0][2]->v, $_[0][3]->v, $_[0][0]);
local $memory{$n};
for(my $i = $s; $s <= $e; $i = $s += $b)
{$memory{$n} = $i; $t = $_[0][4]->v} $t }
sub CALL::v { ref $memory{$_[0][0]} or err("$_[0][0] not a function");
$memory{$_[0][0]}->call( map $_->v, @{ $_[0][1] } ) }
sub LAMBDA::call { my @params = @{ $_[0][1] };
@params and local @memory{@params} = @_[1..$#_]; $_[0][2]->v }
sub LAMBDA::v { 0 }
__DATA__
123 * 456
__END__
2 + 3 * 4
__END__
2 * 3 + 4
__END__
-2**3
__END__
2 > 5 ? 3 : 4
__END__
print 40 + 2
__END__
foo = 12 ; print foo, foo + foo * 3, -1 ; 0
__END__
factorial with n as n > 1 ? n * factorial(n - 1) : 1;
print 5, factorial(5)
__END__
# classic factorial
factorial with n as n > 1 ? n * factorial(n - 1) : 1;
for n from 0 to 10 do print n, factorial(n);
__END__
# towers
tower(3, 1, 2, 3);
tower with n from to spare as
n > 0 and
(
tower( n - 1, from, spare, to );
print n, from, to;
tower( n - 1, spare, to, from );
)
__END__
foo = 5; foo = -1 + print foo while foo > 0;
__END__
qwe = 7; while qwe > 3 do ( print qwe; qwe = qwe - 1; 41; 42 );;;
__END__
| [reply] [Watch: Dir/Any] [d/l] |
|
|