view release on metacpan or  search on metacpan

perl5/Pugs-Compiler-Rule/temp/lib/Pugs/Runtime/Rule.pm  view on Meta::CPAN

package Pugs::Runtime::Rule;

=for About

Original file: pX/Common/iterator_engine.pl - fglock

Old docs are after the __END__.

This is a rewrite of the matching engine, aiming to generate the same data structure as
the 'ratchet' version.

- It currently passes all it's tests.

- The algorithm is a bit simpler than the previous version, but the complexity is the same.

TODO

- The structure generated by concat() still looks like a tree, instead of a 'plain' Match.

- There are no tests yet for <before>, hashes, end_of_string, and the rule wrapper.

- It needs a 'direction' flag, in order to implement <after>.

- Captures need an internal 'counter', see the ratchet version for an implementation
and tests.

- Quantified matches could use less stack space.

- Simplify arg list - the functions currently take 8 arguments.

=cut

use strict;
use warnings;
#use Smart::Comments; #for debugging, look also at Filtered-Comments.pm
use Data::Dumper;
use PadWalker qw( peek_my );  # peek_our ); ???

# note: alternation is first match (not longest). 
# note: the list in @$nodes can be modified at runtime
sub alternation {
    my $nodes = shift;
    return sub {
        my @state = $_[1] ? @{$_[1]} : ( 0, 0 );
        $_[3] = bless \{ bool => \0 }, 'Pugs::Runtime::Match::Ratchet';
        while ( $state[0] <= $#$nodes ) {
            $state[1] = $nodes->[ $state[0] ]->( $_[0], $state[1], @_[2,3,4,5,6,7] );
            $state[0]++ unless $state[1];
            last if $_[3] || ${$_[3]}->{abort};
        }
        return unless $_[3];
        return \@state;
    }
}

sub concat {
    my $nodes = shift;
    return sub {
        my @state = $_[1] ? @{$_[1]} : ();
        do {
            my $st = $nodes->[0]->( $_[0], $state[0], @_[2,3,4,5,6,7] );
            return if ! $_[3] || ${$_[3]}->{abort};
            
            
            $_[3] = { match => [ $_[3] ] };
            $state[1] = $nodes->[1]->( $_[0], $state[1], $_[2], $_[3]->{match}[1], 
                         $_[4], $_[3]->{match}[0]->to, @_[6,7] );
            $state[0] = $st unless $state[1];
            
            
        } while !   $_[3]->{match}[1] && 
                ! ${$_[3]->{match}[1]}->{abort} &&
                $state[0]; 
        $_[3] = bless \{
                bool  => \$_[3]{match}[1]->bool,
                str   => \$_[0],
                from  => \$_[3]{match}[0]->from,
                to    => \$_[3]{match}[1]->to,
                named => { %{$_[3]{match}[0]}, %{$_[3]{match}[1]} },
                match => [ @{$_[3]{match}[0]}, @{$_[3]{match}[1]} ],
                capture => ${$_[3]{match}[1]}->{capture},
                abort   => ${$_[3]{match}[1]}->{abort},
        }, 'Pugs::Runtime::Match::Ratchet';
        return \@state;
    }
}

sub constant { 
    my $const = shift;
    my $lconst = length( $const );
    no warnings qw( uninitialized );
    return sub {
        my $bool = $const eq substr( $_[0], $_[5], $lconst );
        $_[3] = bless \{ 
                bool  => \$bool,
                str   => \$_[0],
                from  => \(0 + $_[5]),