Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Re: Implementing a toy language in perl?

by Anonymous Monk
on Sep 18, 2016 at 21:55 UTC ( [id://1172081]=note: print w/replies, xml ) Need Help??


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__

Replies are listed 'Best First'.
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__

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://1172081]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others cooling their heels in the Monastery: (4)
As of 2024-03-29 06:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found