Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Re^2: Operator Precedence Parser

by bart (Canon)
on Jun 13, 2006 at 11:17 UTC ( #555004=note: print w/ replies, xml ) Need Help??


in reply to Re: Operator Precedence Parser
in thread Operator Precedence Parser

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


Comment on Re^2: Operator Precedence Parser
Select or Download Code
Re^3: Operator Precedence Parser
by Anonymous Monk on Jun 19, 2014 at 22:38 UTC

    Very nice code, much simpler & shorter than I expected. I tried to add an = (Perl or C internal-to-expression assignment) to the operators, though, lowest precedence & right-associative:

    '='=> {prec=> 5,assoc=>'R',exec=>sub { print "DEBUG $_[0]=$_[1]\n"; $_[1]; }, function=>'asg'},

    I added it to the operator pattern:

    if (/\G\s*(\*\*|[=+\-*\/%\\])/gc)

    and kind of defined the LHS variable

    %var=(a=>101,b=>7,q=>'q');

    but it fails because Function::evaluate tries to coerce the value, which I set to the variable name, into a number:

    return $code->(map 0+$_,@{$self->{arguments}});

    I think I have a workaround, but it looks like '=' is a special case because the LHS variable should not be evaluated before calling the assignment function.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (9)
As of 2014-10-25 15:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (145 votes), past polls