Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Re^2: execute a string

by Anonymous Monk
on May 06, 2016 at 22:27 UTC ( #1162401=note: print w/replies, xml ) Need Help??


in reply to Re: execute a string
in thread execute a string

Thanks for posting my code. I was moving to a new state and my computers were all packed up and not accessible and I was going crazy with PWS (perl withdrawal symptoms) (I even started writing perl code in a notebook) until I remembered someone on Freenode #perl had talked about ideone.com. All I had was a small (six inch) tablet that didn't have perl but did have a browser, and now I could write and run perl again :)

I never did figure out how to copy/paste whole programs to PerlMonks. I guess I started a firestorm.

Here's one of the forks done specifically to see if I could expand the technique to producing a parse tree and running it for a small language that had recursive calls with formal parameters. It is self contained and runs multiple test cases in the DATA section.

#!/usr/bin/perl use strict; # perl'ified version of https://en.wikipedia.org/wiki/Prat +t_parser use warnings; # slight mod from http://ideone.com/xbQY9c our (@v, %mem, $running); # external values stack our $ws = qr/(?:#.*|\s+)*+/; # white space sub reduce { push @v, bless [ splice @v, -pop() || @v ], shift } our ($allnouns, %nouns) = # config section ( qr/ \d+(?{'number'}) | print\b | for\b | while\b | - | \( | ([a-zA-Z]\w*) $ws(?:=(?{'store'}) | \((?{'call'}) | (?=as\b|with\b)(?{'as'}) | (?{'fetch'})) /x, 'number' => sub { push @v, bless [ pop ], 'NUM' }, 'print' => sub { push @v, bless [], 'PRINT'; getlist() }, 'fetch' => sub { push @v, bless [ pop ], 'FETCH' }, 'store' => sub { push @v, pop; expr(qr/[-?>+\/]|\*{1,2}/); reduce STORE => 2 }, 'call' => sub { push @v, pop, bless [ ], 'ARGS'; /\G$ws \)/gcx or (getlist(), /\G$ws \)/gcx || err('no )')); reduce CALL => 2 }, 'as' => sub { my $name = pop; push @v, bless [ ], 'PARAMS'; if( /\G with\b/gcx ) { push @{ $v[-1] }, $1 while /\G$ws([a-zA-Z]\w*\b(?<!\bas))/gcx +} /\G$ws as\b/gcx or err('no as'); expr(qr/[-?>+\/]|\*{1,2}|while\b|and\b|or\b/); reduce LAMBDA => 2; $mem{$name} = $v[-1] }, '-' => sub { expr( qr/\*{2}/ ); reduce NEG => 1 }, '(' => sub { expr(); /\G$ws \)/gcx or err("no )") }, 'while' => sub { expr(); /\G$ws do\b/gcx or err('no do'); expr(qr/[-?>+\/]|\*{1,2}|while\b|and\b|or\b/); reduce NWHILE => 2 +}, 'for' => sub { /\G$ws([A-Za-z]\w*)/gcx ? push @v, $1 : err('no varia +ble'); /\G$ws from\b/gcx or err('no from'); expr(); /\G$ws to\b/gcx or err('no to'); expr(); /\G$ws do\b/gcx or err('no do'); expr(qr/[-?>+\/]|\*{1,2}|while\b|and\b|or\b/); reduce FOR => 4 }, ); our ($allverbs, %verbs) = ( qr/[-;?>+\/]|\*{1,2}|while\b|and\b|or\b/, ';' => sub { /\G$ws(?= ; | \) | \z )/gcx or do { expr(qr/[-?>+\/]|\*{1,2}|while\b|and\b|or\b/); $v[-2]->add or reduce STMT => 2 } }, 'while' => sub { expr(qr/[-?>+\/]|\*{1,2}|and\b|or\b|(while\b)/); reduce WHILE => 2 }, 'or' => sub { expr(qr/[-?>+\/]|\*{1,2}|and\b/); reduce OR => 2 }, 'and' => sub { expr(qr/[-?>+\/]|\*{1,2}/); reduce AND => 2 }, '?' => sub { expr(); /\G$ws :/gcx or err("no :"); expr(qr/[-?>+\/]|\*{1,2}/); reduce COND => 3 }, '>' => sub { expr( qr/\+|-|\*{1,2}|\/|(>)/ ); reduce GT => 2 }, '+' => sub { expr( qr/\*{1,2}|\// ); reduce ADD => 2 }, '-' => sub { expr( qr/\*{1,2}|\// ); reduce SUB => 2 }, '*' => sub { expr( qr/\*{2}/ ); reduce MUL => 2 }, '/' => sub { expr( qr/\*{2}/ ); reduce DIV => 2 }, '**' => sub { expr( qr/\*{2}/ ); reduce POW => 2 }, ); sub expr # takes regex of verbs that will shift { (my $shifters, $^R) = pop // $allverbs; /\G$ws/gcx && /\G($allnouns)/gcx ? ($nouns{$@ = $^R // $1} // err("no code for noun '$@' "))->($+) : err('bad noun'); $2 ? err('nonassoc violation') : ($verbs{$1} // err("no code for verb '$1' "))->() while /\G$ws/gcx, /\G($shifters)/gcx; } sub getlist { do { expr(qr/[-?>+\/]|\*{1,2}/); push @{ $v[-2] }, pop @ +v } while /\G$ws ,/gcx } for ( grep /\S/, split /^__END__\n/m, join '', <DATA> ) { eval { $running = @v = %mem = (); expr(); pos() == length() or err("incomplete parse"); print "\n", s/\s*\z/\n/r; #show( $v[-1], 0 ); $running++; print "= ", $v[-1]->v, "\n"; 1 } or err($@); } sub show { my ($t, $i) = @_; print ' ' x $i, ref $t || $t, "\n"; show( $_, $i + 1 ) for ref $t ? @$t : () } sub err { exit print "\n**ERROR** ", $running ? "@_" : s/\G/ <** @_ **> /r, "\n" } sub UNIVERSAL::add { 0 } sub STMT::add { push @{$_[0]}, pop @v } sub ADD::v { $_[0][0]->v + $_[0][1]->v } # interpreter section 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 COND::v { $_[0][0]->v ? $_[0][1]->v : $_[0][2]->v } sub FETCH::v { $mem{$_[0][0]} // err(" variable $_[0][0] never set") } sub STORE::v { $mem{$_[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 $mem{$n};for my $i ($s..$e){$mem{$n} = $i; $t = $_[0][3]->v} $ +t } sub CALL::v { ref $mem{$_[0][0]} or err("$_[0][0] not a function"); $mem{$_[0][0]}->call( map $_->v, @{ $_[0][1] } ) } sub LAMBDA::call { my @params = @{ $_[0][0] }; @params and local @mem{@params} = @_[1..$#_]; $_[0][1]->v } sub LAMBDA::v { 0 } __DATA__ # classic factorial fact with n as n > 1 ? fact(n - 1) * n : 1; for n from 0 to 10 do print n, fact(n); 0; __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__

Hopefully this pasted code will quiet the firestorm.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (6)
As of 2020-05-30 15:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If programming languages were movie genres, Perl would be:















    Results (172 votes). Check out past polls.

    Notices?