After Perl 5.10 release I started to write a regex that parses XML, and ran into similar problems.

What I learned during crafting that expression:

• nested regexes are complicated
• They are still buggy (I found two bugs in the re engine in two days)
• There's a reason we want Perl 6 regexes/rules
• (?{print "matched so far: $&\n"}) blocks really help while debugging
• Use atomic groups wherever possible. Not only for performance reasons, but also to avoid confusing, multiple execution of embedded closures

expr      := number
           | expr ws unary_operator 
           | expr ws expr ws binary_operator
[download]

RULE1 = RULE2 | RULE3
RULE2 = A B
RULE3 = A C
-- becomes --
RULE1x = A ( RULE2x | RULE3x )
RULE2x = B
RULE3x = C
[download]

Parse "1 2 +" as an expr
 Try 'number'
  Parse 'number', left with "2 +"
  Parse 'end', PANIC!
 Try 'expr unary'
  Parse "1 2 +" as an expr
   Try 'number'
    Parse 'number', left with "2 +"
    Parse 'end', PANIC!
   Try 'expr unary'
   ...
[download]

Parse "1 2 +" as an expr
 Try 'number'
  Parse 'number', left with "2 +"
  Parse 'end', PANIC!
 Try 'expr unary'
  Parse 'number', left with "2 +"
  Parse 'unary', PANIC!
 Try 'expr binary'
  Parse 'number', left with "2 +"
  Parse 'number', left with "+"
  Parse 'binary', left with ""
  Parse 'end', done!
[download]

my %ops = (
    '+' => sub { $_[0] + $_[1] },
    '-' => sub { $_[0] - $_[1] },
    '*' => sub { $_[0] * $_[1] },
    '/' => sub { $_[0] / $_[1] },
    '^' => sub { $_[0] ** $_[1] },
    'nat' => sub { sin($_[0]) / cos($_[0]) },
    'soc' => sub { cos($_[0]) },
    'nis' => sub { sin($_[0]) },
    'trqs' => sub { sqrt($_[0]) },
    'rqs' => sub { $_[0] * $_[0] },
    'sba' => sub { abs($_[0]) },
    'shc' => sub { -$_[0] },
);

$RPN3 = qr#
    (?(DEFINE)
        (?<expr>
            (?> ((?&number)) (?{ push @stack, scalar reverse $^N }) )
            |
            (?: (?> ((?&unary)) ) \s+ (?> (?&expr) ) (?{ push @stack, 
+$ops{$^N}->( pop @stack )  }) )
            |
            (?: (?> ((?&binary)) ) \s+ (?> (?&expr) ) \s+ (?> (?&expr)
+ ) (?{ push @stack, $ops{$^N}->( pop @stack, pop @stack ) }) )
        )
        (?<number>
            ( (?> \d* ) (?> [.] ) (?> \d+ ) | (?> \d+ ) (?> [.] ) | \d
++ )
        )
        (?<unary>
            ( shc | sba | rqs | trqs | nis | soc | nat )
        )
        (?<binary>
            ( [-+/*^] )
        )
    )

    (?{ @stack = (); $result = undef; })
    ^ \s* (?&expr) (?{ $result = $stack[0] }) \s* $
#sx;

(reverse $line) =~ $RPN3;
[download]

Brilliant! I knew I was overlooking something simple (that doesn't mean obvious). My only criticism is that the regex should be $NPR = qr{...} ;)

I haven't read everything yet, but I thought I'd post a link to a tutorial of mine before I come back to this. Operator Associativity and Eliminating Left-Recursion in Parse::RecDescent was written for Parse::RecDescent, but the principles apply to other LL parsers too.

Quickly, I think

expr : expr expr binop
       { [ BINOP => [ $item[3], $item[1], $item[2] ] ] }

     | term
[download]

can be transformed into

expr  : term { push($item[1]) } expr_

      | term

expr_ : expr binop
        { [ BINOP => [ $item[2], pop(), $item[1] ] ] }
[download]

Factoring out common prefixes for speed:

expr   : term { push($item[1]) } expr_1

expr_1 : expr_2

       | # Automatic match
         { pop() }

expr_2 : expr binop
         { [ BINOP => [ $item[2], pop(), $item[1] ] ] }
[download]

Inlining expr_2 for simplicity:

expr  : term { push($item[1]) } expr_

expr_ : expr binop
        { [ BINOP => [ $item[2], pop(), $item[1] ] ] }

      | # Automatic match
         { pop() }
[download]

In short, keep looking for terms until you meet something that isn't (an operator), then eat up the last two terms that have been met.

I'll come back later to verify this and put it into 5.10 regex syntax.

Update: Fixed link

Thanks for the link, it is great article. I've only skimmed it but it gets to the nub of the problem I had. I'll reread it and explore further, this time with a map;)

The push and pop aren't accurate. I was trying to emulate P::RD's args. At the very least, the push needs to undo on backtracking (which is easy to implement even in pre-5.10).

I need to read up on Perl 5.10 regexps before I can deliver a regexp version of that grammar, but right now, I'm out of town on a small screen. It'll have to wait.

I finally got back to this thread!

A couple of quick comments first:

I wanted to use recursion [...] The obvious choice was a regular expression to match and evaluate Reverse Polish Notation (RPN).

That's actually a very poor choice. The advantage of RPN is that it can be parsed with neither backtracking nor recursion. Parsing RPN can be simplified to checking the size of a stack.

It occurred to me later that I could eliminate recursion entirely,

What should have occurred to you is that you had already eliminated recursion entirely.

I feel you left the tracks you intended to visit. You did so when you replaced the recursion with stack checks (e.g. (?(?{ @stack < 1 }) (*FAIL) )). At that point, you stopped using the regexp engine as a parser since you moved all but the tokenizing back into Perl. Since the intent was to develop a parser as a regexp pattern, let's revisit the recursive method.

First, let's go back to the EBNF grammar.

expr      := number
           | expr ws unary_op 
           | expr ws expr ws binary_op
number    := digit {digit} [ '.' {digit} ]
           | '.' digit {digit}
digit     := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
unary_op  := "chs" | "abs" | "sqr" | "sqrt" | "sin" | "cos" | "tan"
binary_op := '+' | '-' | '*' | '/' | '^'
ws        := ' ' | '\t' | '\r' | '\n'
[download]

If you tried to build a regexp from that, you'd get

Infinite recursion in regex
[download]

When something other than a number is found while trying to match an expr, it tries to match an expr.
It finds something other than a number, so it tries to match an expr.
It finds something other than a number, so it tries to match an expr.
...

This type of parser is known as a LL parser. Left recursion ("rule : rule ..." or something that reduces to that) must be eliminated from the rules of a LL parser. This is to what I was alluding in my earlier post.

expr      := number
           | expr ws unary_op 
           | expr ws expr ws binary_op
[download]

becomes

expr      := number expr_
expr_     := ws expr ws binary_op expr_
           | ws unary_op expr_
           |
[download]

At this point, building the regexp is straightforward:

qr{
   (?(DEFINE)
      (?<expr>
         (?&number) (?&expr_)
      )

      (?<expr_>
         (?:
            \s++
            (?:
               (?&expr) \s++ (?&binary_op) (?&expr_)
            |  
               (?&unary_op) (?&expr_)
            )
         )?
      )

      (?<number>
         ( (?&NUMBER) )
         (?{
            local @stack = @stack;
            push @stack, $^N;
         })
      )

      (?<unary_op>
         ( (?&IDENT) )
         (?(?{ !exists($unary_ops{$^N}) }) (*FAIL) )
         (?{
            local @stack = @stack;
            $unary_ops{$^N}->($stack[-1]);
         })
      )

      (?<binary_op>
         ( [-+/*^] )
         (?{
            local @stack = @stack;
            $binary_ops{$^N}->($stack[-2], pop(@stack));
         })
      )


      # Tokens.
      # Backtracking can't cause a token
      # rule to return something different.

      (?<NUMBER> \d++ (?: [.] \d*+ )?+ | [.] \d++ )
      (?<IDENT>  [_A-Za-z][_A-Za-z0-9]*+          )

   )

   (?{ local @stack = (); })
   \A \s* (?&expr) \s* \z
   (?{ $result = pop(@stack) })
}sx;
[download]

Notice the complete lack of stack size check? The grammar enforces the right number of arguments, preventing us from having an invalid stack.

By the way, getting an identifier and checking if it's one of the operators is a much more robust then just looking for the operator names. It also results in better error messages. It isn't strictly needed here, but this is an educational venture, right?

I made some small changes to the Perl interface, so the harness needs to be changed slightly:

#!/usr/bin/perl

use 5.010_000;  # re features

use warnings;
use strict;

our @stack;
our $result;

my %unary_ops = (
    chs  => sub { $_[0] = -$_[0] },
    abs  => sub { $_[0] = abs $_[0] },
    sqr  => sub { $_[0] *= $_[0] },
    sqrt => sub { $_[0] = sqrt $_[0] },
    sin  => sub { $_[0] = sin $_[0] },
    cos  => sub { $_[0] = cos $_[0] },
    tan  => sub { $_[0] = sin $_[0] / cos $_[0] },
);

my %binary_ops = (
    '+' => sub { $_[0] += $_[1] },
    '-' => sub { $_[0] -= $_[1] },
    '/' => sub { $_[0] /= $_[1] },
    '*' => sub { $_[0] *= $_[1] },
    '^'  => sub { $_[0]**= $_[1] },
);

my $RPN = qr{
   ...
};

my %input = (
   ...
);

foreach my $line ( keys %input ) {
    local $result;
    my ($expression) = $line =~ /($RPN)/;
    ...
}
[download]

Results:

OK: .456 = .456
OK: 123. = 123.
OK: 4 2 + = 6
OK: 123 / is invalid, got no result
OK: 24 abs = 24
OK: 1 24 abs + sqrt = 5
OK: 12 34 is invalid, got no result
OK: 123 34 * chs = -4182
OK: 4 2 - = 2
OK: 34 2 / 2 ^ = 289
OK: 24 4 + chs sqr = 784
OK: 123.456 + is invalid, got no result
OK: 123 chs 34 * = -4182
OK: fail is invalid, got no result
OK: 24 chs abs = 24
OK: 25 abs sqrt = 5
OK: 12 34+ is invalid, got no result
OK: 12 34 + + is invalid, got no result
OK: 123 chs chs chs = -123
OK: 1 24abs+sqrt is invalid, got no result
OK: 12 34 + 56 + = 102
OK: 123 chs = -123
OK: 24 = 24
OK: 1 fail is invalid, got no result
OK: 12 34 56 + + = 102
OK: 4 2 ^ = 16
OK: 123 chs chs chs chs = 123
OK: 3 34 2 / 2 ^ * = 867
OK: 25 chs abs sqrt = 5
OK: 123.456 = 123.456
OK:  123  = 123
OK: 123 chs chs = 123
OK: 24 chs = -24
OK: 123 = 123
OK: 24abs is invalid, got no result
OK: 4 2 / = 2
OK: 24abssqrt is invalid, got no result
OK: 4 2 * = 8
[download]

pl@nereida:~/Lperltesting$ cat calc510withactions.pl
#!/usr/local/lib/perl/5.10.1/bin//perl5.10.1
use v5.10;

# Infix to postfix translator using 5.10 regexp
# original grammar:
#  exp ->   exp '-' digits
#         | digits
#
# Applying left-recursion elimination we have:
#  exp ->   digits rest
#  rest ->   '-' rest
#          | # empty
#
my @stack;
my $regexp = qr{
    (?&exp)

    (?(DEFINE)
        (?<exp>    (?&digits) \s* (?&rest)
        )

        (?<rest>     \s* - (?&digits) \s* (?{ push @stack, '-' }) (?&r
+est)
                  |  # empty
        )

        (?<digits>  \s* (\d+)
           (?{ push @stack, $^N })
        )
    )
}xms;

my $input = <>;
chomp($input);
if ($input =~ $regexp) {
  say "matches: $&\nStack=(@stack)";
}
else {
  say "does not match";
}
[download]