Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??

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__

In reply to Re^2: Implementing a toy language in perl? by tybalt89
in thread Implementing a toy language in perl? by BUU

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (4)
As of 2024-03-29 15:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found