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__
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.