Parse::RecDescent triggers infinete loop in perl5.9.0 and 5.8.1 [perl #17757]

[David Dyck]

On Sat, 8 Mar 2003 at 20:19 -0800, David Dyck <[EMAIL PROTECTED]> wrote:

> On Fri, 7 Mar 2003 at 21:32 -0800, David Dyck <[EMAIL PROTECTED]> wrote:
>
> > On Mon, 3 Mar 2003 at 06:02 -0000, [EMAIL PROTECTED] wrote:
> >
> > > The simplest I had with Inline was:
> > > BEGIN {
> > >     require Inline;
> > >     Inline->import(qw/ Config DIRECTORY _Inline_test /);
> > >     Inline->import('C', 'void true() { }');
> > >     Inline->import('C', 'void true2() { }');
> > > }
> > >

> I'm still hoping that this information will trigger some ideas
> on how to make a stand alone (non Inline) test case.


The following code using Parse::RecDescent does
an infinite loop with perl5.9.0  (presuming with 5.8.1)
but finishes fine with perl5.8.0.  I haven't simplified
this as much as I could yet, the grammar comes
from derived from Inline::C::ParseRecDescent, where
I first saw the problem in its make test.

I think that this shows that the problem is not in
Inline::C so I'll stop cc'ing the inline mailing list
after this email

What has changed since 5.8.0 that causes this problem?

  David


use strict;

# derived from Inline::C::ParseRecDescent

sub get_parser {
    require Parse::RecDescent;
    $main::RD_HINT++;
    Parse::RecDescent->new(grammar())
}


sub grammar {
    <<'END';

code:   part(s)
        {
         return 1;
        }

part:   comment
      | function_definition
        {
         my $function = $item[1][0];
         $return = 1, last if $thisparser->{data}{done}{$function}++;
         push @{$thisparser->{data}{functions}}, $function;
         $thisparser->{data}{function}{$function}{return_type} =
             $item[1][1];
         $thisparser->{data}{function}{$function}{arg_types} =
             [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}];
         $thisparser->{data}{function}{$function}{arg_names} =
             [map {ref $_ ? $_->[1] : '...'} @{$item[1][2]}];
        }
      | function_declaration
        {
         $return = 1, last unless $thisparser->{data}{AUTOWRAP};
         my $function = $item[1][0];
         $return = 1, last if $thisparser->{data}{done}{$function}++;
         my $dummy = 'arg1';
         push @{$thisparser->{data}{functions}}, $function;
         $thisparser->{data}{function}{$function}{return_type} =
             $item[1][1];
         $thisparser->{data}{function}{$function}{arg_types} =
             [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}];
         $thisparser->{data}{function}{$function}{arg_names} =
             [map {ref $_ ? ($_->[1] || $dummy++) : '...'} @{$item[1][2]}];
        }
      | anything_else

comment:
        m{\s* // [^\n]* \n }x
      | m{\s* /\* (?:[^*]+|\*(?!/))* \*/  ([ \t]*)? }x

function_definition:
        rtype IDENTIFIER '(' <leftop: arg ',' arg>(s?) ')' '{'
        {
         [EMAIL PROTECTED],1], $item[4]]
        }

function_declaration:
        rtype IDENTIFIER '(' <leftop: arg_decl ',' arg_decl>(s?) ')' ';'
        {
         [EMAIL PROTECTED],1], $item[4]]
        }

rtype:  rtype1 | rtype2

rtype1: modifier(s?) TYPE star(s?)
        {
         $return = $item[2];
         $return = join ' ',@{$item[1]},$return
           if @{$item[1]} and $item[1][0] ne 'extern';
         $return .= join '',' ',@{$item[3]} if @{$item[3]};
         return undef unless (defined $thisparser->{data}{typeconv}
                                                   {valid_rtypes}{$return});
        }

rtype2: modifier(s) star(s?)
        {
         $return = join ' ',@{$item[1]};
         $return .= join '',' ',@{$item[2]} if @{$item[2]};
         return undef unless (defined $thisparser->{data}{typeconv}
                                                   {valid_rtypes}{$return});
        }

arg:    type IDENTIFIER [EMAIL PROTECTED],2]]}
      | '...'

arg_decl:
        type IDENTIFIER(s?) {[$item[1], $item[2][0] || '']}
      | '...'

type:   type1 | type2

type1:  modifier(s?) TYPE star(s?)
        {
         $return = $item[2];
         $return = join ' ',@{$item[1]},$return if @{$item[1]};
         $return .= join '',' ',@{$item[3]} if @{$item[3]};
         return undef unless (defined $thisparser->{data}{typeconv}
                                                   {valid_types}{$return});
        }

type2:  modifier(s) star(s?)
        {
         $return = join ' ',@{$item[1]};
         $return .= join '',' ',@{$item[2]} if @{$item[2]};
         return undef unless (defined $thisparser->{data}{typeconv}
                                                   {valid_types}{$return});
        }

modifier:
        'unsigned' | 'long' | 'extern' | 'const'

star:   '*'

IDENTIFIER:
        /\w+/

TYPE:   /\w+/

anything_else:
        /.*/

END
}

BEGIN { $::RD_TRACE = 1; }

get_parser()->code('void true() { }');
get_parser()->code('void true2() { }');