Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
I wrote my own constructing a Tree::Simple tree as output.
For completeness sake, I've rewritten the parser so it produces a parse tree. I took a quick look at Tree::Simple, and I found it too hard to my taste for the little benefit it would give me, so I'm using a handrolled function object instead — yes I'm converting the infix operators into prefix function calls. As an extra benefit, I can use overload to return a symbolic representation of the parse tree when used as a string, or actually evaluate it, when used as a number.

I think it clearly demontrates its viability as a parser for real work.

update Now with symbolic (postponed) variables, meaning: if you change the value of the variable in the %var hash, the value used in an evaluation by using a parsed expression in a numerical context, will change accordingly.

#!perl -w use strict; my %var; my %op = ( '+' => { prec => 10, assoc => 'L', exec => sub { $_[0] + $_[1] }, f +unction => 'sum'}, '-' => { prec => 10, assoc => 'L', exec => sub { $_[0] - $_[1] }, f +unction => 'dif'}, '*' => { prec => 20, assoc => 'L', exec => sub { $_[0] * $_[1] }, f +unction => 'mul'}, '/' => { prec => 20, assoc => 'L', exec => sub { $_[0] / $_[1] }, f +unction => 'div'}, '%' => { prec => 20, assoc => 'L', exec => sub { $_[0] % $_[1] }, f +unction => 'mod'}, '**' => { prec => 30, assoc => 'R', exec => sub { $_[0] ** $_[1] }, +function => 'pow'}, ); my %function = ( sumsq => sub { my $sum = 0; foreach(@_) { $sum += $_*$_; } return $ +sum; }, sqrt => sub { return sqrt shift; }, negate => sub { return -shift }, ); # turn the operators into a function foreach my $op (values %op) { $function{$op->{function}} = $op->{exec}; } { # Function class package Function; sub new { # Function->new($funcname => @arguments) my $class = shift; my %self; $self{function} = shift; $self{arguments} = [ @_ ]; return bless \%self, $class; } sub stringify { my $self = shift; local $" = ", "; return "$self->{function}(@{$self->{arguments}})"; } use overload '""' => \&stringify; sub evaluate { my $self = shift; my $code = $function{$self->{function}} or die "No code provid +ed for '$self->{function}'"; return $code->(map 0+$_, @{$self->{arguments}}); } use overload '0+' => \&evaluate, fallback => 1; } { # class Var package Var; sub new { # Var->new($name); my $class = shift; my $name = shift; return bless \$name, $class; } sub stringify { my $self = shift; return "$$self"; } use overload '""' => \&stringify; sub fetch { my $self = shift; exists $var{$$self} or warn "Use of uninitialised variable '$$ +self'"; return $var{$$self} || 0; } use overload '0+' => \&fetch, fallback => 1; } # fields: use constant VALUE => 0; use constant OP => 1; use constant PREC => 2; use constant TRACE => 1; sub parse_expr { my @stack; push @stack, [ undef, undef, 0 ]; # sentinel while (1) { trace() if TRACE; my($value) = parse_value() or die "Parse error at " . where(); trace("value=$value") if TRACE; my($op, $prec); if(/\G\s*(\*\*|[+\-*\/%\\])/gc) { # operator $op = $1; $prec = $op{$op}{prec}; trace("op=$op") if TRACE; } else { # no more $prec = 0; } # process while($stack[-1][PREC] > $prec) { my($lhs, $op) = @{pop @stack}; trace("popping $lhs $op") if TRACE; $value = Function->new($op{$op}{function}, $lhs, $value); trace("result = $value") if TRACE; } if($prec) { if($op{$op}{assoc} eq 'L') { $prec++; } push @stack, [ $value, $op, $prec ]; } else { pop @stack; # sentinel return $value; } } } sub parse_value { /\G\s+/gc; if(/\G\+/gc) { # '+' value trace("Unary plus") if TRACE; return parse_value(); } if(/\G-/gc) { # '-' value trace("Unary minus") if TRACE; return Function->new(negate => parse_value()); } if(/\G((?:\d+\.?\d*|\.\d+)(?i:E[+-]?\d+)?)/gc) { # number return $1; } if(/\G((?i:[a-z]\w*))\s*\(/gc) { # function '(' my $function = $1; $function{$function} or die sprintf "Undefined function '$func +tion' called at: \"%s\"", where(); my @arg; unless(/\G\s*(?=\))/gc) { while(1){ my($value) = parse_expr() or die sprintf "Expression e +xpected at: \"%s\"", where(); push @arg, $value; /\G\s*,/gc or last; } } /\G\s+/gc; /\G\)/gc or die sprintf "Parse error: ')' expected at: \"%s\"" +, where(); trace(sprintf "function '$function' called with %d argument%s" +, scalar @arg, @arg==1 ? "" : "s") if TRACE; return Function->new($function, @arg); } if(/\G((?i:[a-z]\w*))/gc) { # variable return Var->new($1); } if(/\G\(/gc) { # '(' expr ')' my $value = parse_expr(); /\G\s+/gc; /\G\)/gc or die sprintf "Parse error: ')' expected at: \"%s\"" +, where(); return $value; } return; } sub evaluate { local $_ = shift; my $value = parse_expr(); /\G\s+/gc; /\G$/gc or die sprintf "Junk characters at end: \"%s\"", where(); return $value; } sub where { # debugging info my $s = $_; substr($s, pos || 0, 0) = "\267"; return $s; } sub trace { my($pkg, $file, $line) = caller; printf STDERR "Line %d \"%s\" %s\n", $line, where(), @_ ? shift : +""; } %var = ( a => 101, b => 7 ); $_ = "a+sumsq(3,2+2)*sqrt(36)/2"; my $result = evaluate($_); print "\nsource: $_\n"; use Data::Dumper; $Data::Dumper::Indent = 1; print "Dumped:\n", Dumper $result; print "Stringified: $result\n"; print "Numerified with a=$var{a}: " . (0+$result) . "\n"; $var{a} = 25; print "Numerified with a=$var{a}: " . (0+$result) . "\n";

Output:

Line 86 "·a+sumsq(3,2+2)*sqrt(36)/2" Line 88 "a·+sumsq(3,2+2)*sqrt(36)/2" value=a Line 93 "a+·sumsq(3,2+2)*sqrt(36)/2" op=+ Line 86 "a+·sumsq(3,2+2)*sqrt(36)/2" Line 86 "a+sumsq(·3,2+2)*sqrt(36)/2" Line 88 "a+sumsq(3·,2+2)*sqrt(36)/2" value=3 Line 86 "a+sumsq(3,·2+2)*sqrt(36)/2" Line 88 "a+sumsq(3,2·+2)*sqrt(36)/2" value=2 Line 93 "a+sumsq(3,2+·2)*sqrt(36)/2" op=+ Line 86 "a+sumsq(3,2+·2)*sqrt(36)/2" Line 88 "a+sumsq(3,2+2·)*sqrt(36)/2" value=2 Line 100 "a+sumsq(3,2+2·)*sqrt(36)/2" popping 2 + Line 102 "a+sumsq(3,2+2·)*sqrt(36)/2" result = sum(2, 2) Line 142 "a+sumsq(3,2+2)·*sqrt(36)/2" function 'sumsq' called with 2 a +rguments Line 88 "a+sumsq(3,2+2)·*sqrt(36)/2" value=sumsq(3, sum(2, 2)) Line 93 "a+sumsq(3,2+2)*·sqrt(36)/2" op=* Line 86 "a+sumsq(3,2+2)*·sqrt(36)/2" Line 86 "a+sumsq(3,2+2)*sqrt(·36)/2" Line 88 "a+sumsq(3,2+2)*sqrt(36·)/2" value=36 Line 142 "a+sumsq(3,2+2)*sqrt(36)·/2" function 'sqrt' called with 1 ar +gument Line 88 "a+sumsq(3,2+2)*sqrt(36)·/2" value=sqrt(36) Line 93 "a+sumsq(3,2+2)*sqrt(36)/·2" op=/ Line 100 "a+sumsq(3,2+2)*sqrt(36)/·2" popping sumsq(3, sum(2, 2)) * Line 102 "a+sumsq(3,2+2)*sqrt(36)/·2" result = mul(sumsq(3, sum(2, 2)) +, sqrt(36)) Line 86 "a+sumsq(3,2+2)*sqrt(36)/·2" Line 88 "a+sumsq(3,2+2)*sqrt(36)/2·" value=2 Line 100 "a+sumsq(3,2+2)*sqrt(36)/2·" popping mul(sumsq(3, sum(2, 2)), + sqrt(36)) / Line 102 "a+sumsq(3,2+2)*sqrt(36)/2·" result = div(mul(sumsq(3, sum(2, + 2)), sqrt(36)), 2) Line 100 "a+sumsq(3,2+2)*sqrt(36)/2·" popping a + Line 102 "a+sumsq(3,2+2)*sqrt(36)/2·" result = sum(a, div(mul(sumsq(3, + sum(2, 2)), sqrt(36)), 2)) source: a+sumsq(3,2+2)*sqrt(36)/2 Dumped: $VAR1 = bless( { 'function' => 'sum', 'arguments' => [ bless( do{\(my $o = 'a')}, 'Var' ), bless( { 'function' => 'div', 'arguments' => [ bless( { 'function' => 'mul', 'arguments' => [ bless( { 'function' => 'sumsq', 'arguments' => [ '3', bless( { 'function' => 'sum', 'arguments' => [ '2', '2' ] }, 'Function' ) ] }, 'Function' ), bless( { 'function' => 'sqrt', 'arguments' => [ '36' ] }, 'Function' ) ] }, 'Function' ), '2' ] }, 'Function' ) ] }, 'Function' ); Stringified: sum(a, div(mul(sumsq(3, sum(2, 2)), sqrt(36)), 2)) Numerified with a=101: 176 Numerified with a=25: 100

In reply to Re^2: Operator Precedence Parser by bart
in thread Operator Precedence Parser by bart

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!
  • 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
  • Outside of code tags, you may need to use entities for some characters:
            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 exploiting the Monastery: (4)
    As of 2014-09-16 22:00 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (50 votes), past polls