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

Re: execute a string

by beech (Parson)
on May 04, 2016 at 07:39 UTC ( #1162154=note: print w/replies, xml ) Need Help??


in reply to execute a string

Since Reaped: Re: execute a string was reaped here is what it said, see http://ideone.com/6TneLv Part of my continuing quest to write ever smaller parsers.

And the code , in the form of a shell session , showing that it works

$ cat ideone-6TneLv.pl #!/usr/bin/perl our @v; # external values stack our ($allnouns, %nouns) = ( qr/\d+(?{'number'})|[-(]/, 'number' => sub { push @v, pop }, '-' => sub { expr( qr/\*{2}/ ); $v[-1] = -$v[-1] }, '(' => sub { expr(); /\G\s*\)/gcx or err("no )") }, ); our ($allverbs, %verbs) = ( qr/[-+\/]|\*{1,2}/, '+' => sub { expr( qr/\*{1,2}|\// ); $v[-2] += pop @v }, '-' => sub { expr( qr/\*{1,2}|\// ); $v[-2] -= pop @v }, '*' => sub { expr( qr/\*{2}/ ); $v[-2] *= pop @v }, '/' => sub { expr( qr/\*{2}/ ); $v[-2] /= pop @v }, '**' => sub { expr( qr/\*{2}/ ); $v[-2] **= pop @v }, ); sub expr # takes regex of verbs that will shift { (my $shifters, $^R) = pop // $allverbs; /\G\s*($allnouns)/gcx ? $nouns{$^R // $1}->($1) : err('bad noun'); $verbs{$1}->() while /\G\s*($shifters)/gcx; } while(<>) { eval { @v = (); expr(); /\G\s*\z/gcx or err('incomplete') } or err($ +@); print s/\s*\z/ = @v\n/r; } sub err { exit print "ERROR ", s/\G/ <@_> /r, " \n" } $ $ cat ideone-6TneLv.stdin.txt 2 * 3 2+3 2*3-4 (2-3*4) -2**4 1+2+3+4+5+6+7+8+9+10 $ perl ideone-6TneLv.pl < ideone-6TneLv.stdin.txt > ideone-6TneLv.stdo +ut.txt $ cat ideone-6TneLv.stdout.txt 2 * 3 = 6 2+3 = 5 2*3-4 = 2 (2-3*4) = -10 -2**4 = -16 1+2+3+4+5+6+7+8+9+10 = 55

It needs Minimum version of perl : v5.13.2

That website says the code was forked 3 times but I can't work out how to see those forks

This is how you would turn that while loop into sub calc

sub Calc { local($_) = @_; local @v = (); eval { expr(); /\G\s*\z/gcx or err( 'incomplete' ); } or err( $@ ); return @v; } while( <> ) { s/[\r\n]*//g; ## "chomp" print $_," = ", Calc($_), "\n"; }

You might further modify it to run on more perl versions, remove defined-or operator(//) and non-destructive substitution (r flag in s///r)

Replies are listed 'Best First'.
Re^2: execute a string
by Anonymous Monk on May 06, 2016 at 22:27 UTC

    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://1162154]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (7)
As of 2020-04-08 16:35 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The most amusing oxymoron is:
















    Results (45 votes). Check out past polls.

    Notices?