Re^2: execute a string

[Anonymous Monk]

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.