Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

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.


In reply to Re^2: execute a string by Anonymous Monk
in thread execute a string by Anonymous Monk

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



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

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

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















      Results (169 votes). Check out past polls.

      Notices?