view release on metacpan or  search on metacpan

share/P6STD/CursorBase.pmc  view on Meta::CPAN

    my $tpos = shift;

    $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
    if (DEBUG & DEBUG::cursors) {
        my $peek = substr($::ORIG,$tpos,20);
        $peek =~ s/\n/\\n/g;
        $peek =~ s/\t/\\t/g;
        $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
    }
    my %r = %$self;
#    $r{_from} = $self->{_pos} // 0;
    $r{_pos} = $tpos;

    bless \%r, ref $self;
}

sub cursor_force { my $self = shift;
    my $tpos = shift;

    $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
    if (DEBUG & DEBUG::cursors) {
        my $peek = substr($::ORIG,$tpos,20);
        $peek =~ s/\n/\\n/g;
        $peek =~ s/\t/\\t/g;
        $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
    }
    my %r = %$self;
#    $r{_from} = $self->{_pos} // 0;
    $r{_pos} = $::HIGHWATER = $tpos;

    bless \%r, ref $self;
}

sub cursor_rev { my $self = shift;
    my $fpos = shift;

    if (DEBUG & DEBUG::cursors) {
        my $peek = substr($::ORIG,$fpos,20);
        $peek =~ s/\n/\\n/g;
        $peek =~ s/\t/\\t/g;
        $self->deb("cursor_ref to $fpos --------->$GREEN$peek$CLEAR");
    }
    my %r = %$self;
    $r{_pos} = $fpos;

    bless \%r, ref $self;
}

#############################################################
# Regex service routines
#############################################################

sub callm { my $self = shift;
    my $arg = shift;
    my $class = ref($self) || $self;

    my $lvl = 0;
    my $extralvl = 0;
    my @subs;
    if (DEBUG & DEBUG::callm_show_subnames) {
        while (my @c = caller($lvl)) {
            $lvl++;
            my $s = $c[3];
            if ($s =~ /::_/) {
                next;
            }
            elsif ($s =~ /^(?:Cursor|CursorBase)?::/) {
                next;
            }
            elsif ($s =~ /^LazyMap::/) {
                next;
            }
            elsif ($s =~ /^\(eval\)/) {
                next;
            }
            else {
                $extralvl = $lvl unless $extralvl;
                $s =~ s/.*:://;
                push @subs, $s;
            }
        }
    }
    else {
        while (my @c = caller($lvl)) { $lvl++; }
    }
    my ($package, $file, $line, $subname, $hasargs) = caller(1);
    my $name = $subname;
    if (defined $arg) { 
        $name .= " " . $arg;
    }
    my $pos = '?';
    $self->deb($name, " [", $file, ":", $line, "] $class") if DEBUG & DEBUG::trace_call;
    if (DEBUG & DEBUG::callm_show_subnames) {
        $RED . join(' ', reverse @subs) . $CLEAR . ':' x $extralvl;
    }
    else {
        ':' x $lvl;
    }
}

sub retm {
    return $_[0] unless DEBUG & DEBUG::trace_call;
    my $self = shift;
    warn "Returning non-Cursor: $self\n" unless exists $self->{_pos};
    my ($package, $file, $line, $subname, $hasargs) = caller(1);
    $self->deb($subname, " returning @{[$self->{_pos}]}");
    $self;
}

sub _MATCHIFY { my $self = shift;
    my $S = shift;
    my $name = shift;
    return () unless @_;
    my $xact = $self->{_xact};
    my @result = lazymap( sub { my $x = shift; $x->{_xact} = $xact; $x->_REDUCE($S, $name)->retm() }, @_);
    if (wantarray) {
        @result;
    }
    else {
        $result[0];
    }
}

sub _MATCHIFYr { my $self = shift;
    my $S = shift;
    my $name = shift;
    return () unless @_;
    my $var = shift;
#    $var->{_from} = $self->{_from};
    my $xact = $self->{_xact};
    $var->{_xact} = $xact;
    $var->_REDUCE($S, $name)->retm();
}

sub _SCANf { my $self = shift;

    local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
    my $eos = @::ORIG;

    my $pos = $self->{_pos};
    my $C = $self->cursor_xact("SCANf $pos");
    my $xact = $C->xact;

    lazymap( sub { $self->cursor($_[0])->retm() }, LazyRange->new($xact, $pos,$eos) );
}

sub _SCANg { my $self = shift;

    local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
    my $pos = $self->{_pos};
    my $eos = @::ORIG;
    my $C = $self->cursor_xact("SCANg $pos");
    my $xact = $C->xact;

    lazymap( sub { $C->cursor($_[0])->retm() }, LazyRangeRev->new($xact, $eos,$pos) );
}

sub _STARf { my $self = shift;
    my $block = shift;
    no warnings 'recursion';

    local $CTX = $self->callm if DEBUG & DEBUG::trace_call;

    my $pos = $self->{_pos};
    my $C = $self->cursor_xact("SCANf $pos");

share/P6STD/CursorBase.pmc  view on Meta::CPAN

    if (DEBUG & DEBUG::autolexer) {
        print ::LOG "JIT DFA node generation:\n";
        _dfa_dump_node($node);
    }

    $node->[0];
}

sub _scan_regexes { my ($class, $key) = @_;
    no strict 'refs';
    (${ $class . "::REGEXES" } //= do {
        my $stash = \ %{ $class . "::" };
        my %over;
        my %proto;

        for my $m (keys %$stash) {
            next if ref $stash->{$m};  # use constant
            next if !defined *{$stash->{$m}}{CODE};
            my ($meth, $p) = $m =~ /^(.*?)(__S_\d\d\d.*)?__PEEK$/ or next;
            #$self->deb("\tfound override for $meth in $m") if DEBUG & DEBUG::autolexer;
            $over{$meth} = 1;
            push @{$proto{$meth}}, $m if $p;
        }

        for (keys %proto) {
            @{$proto{$_}} = sort @{$proto{$_}};
        }

        $proto{ALL} = [ keys %over ];
        \%proto;
    })->{$key};
}

sub _AUTOLEXgenDFA { my ($self, $realkey, $key, $retree) = @_;
    local $::AUTOLEXED{$realkey} = $fakepos;

    my $lang = ref $self;

    $self->deb("AUTOLEXgen $key in $lang") if DEBUG & DEBUG::autolexer;
    my $ast = $retree->{$key};

    UP: {
        # Whenever possible, we want to share a lexer amongst as many grammars
        # as we can.  So we try to float lexers up to superclasses.

        no strict 'refs';
        my $isa = \@{ $lang . "::ISA" };

        # We don't support multiple inheritance (can we?)
        if (@$isa != 1) {
            $self->deb("\tcannot reuse $key; multiply inherited") if DEBUG & DEBUG::autolexer;
            last;
        }

        my $super = $isa->[0];

        my $dic = $ast->{dic} //= do {
            my $i = 1; # skip _AUTOLEXpeek;
            my $pkg = 'CursorBase';
            $pkg = caller($i++) while $pkg eq 'CursorBase';
            #print STDERR "dic run: $pkg\n";
            $self->deb("\tdeclared in class $pkg") if DEBUG & DEBUG::autolexer;
            $pkg;
        };

        my $ar = ${ $lang . "::ALLROLES" } //= do {
            +{ map { $_->name, 1 } ($lang->meta, $lang->meta->calculate_all_roles) }
        };

        # It doesn't make sense to float a lexer above Cursor, or (for 'has'
        # regexes), the class of definition.
        if ($ar->{$dic}) {
            $self->deb("\tcannot reuse $key; at top") if DEBUG & DEBUG::autolexer;
            last;
        }

        my $supercursor = $self->cursor_fresh($super);
        my $superlexer  = eval {
            local %::AUTOLEXED;
            $supercursor->_AUTOLEXpeek($key, $retree)
        };

        if (!$superlexer) {
            $self->deb("\tcannot reuse $key; failed ($@)") if DEBUG & DEBUG::autolexer;
            last;
        }

        my $ml = _scan_regexes($lang, 'ALL');

        for my $meth (@$ml) {
            if ($superlexer->{USED_METHODS}{$meth}) {
                $self->deb("\tcannot reuse $key; $meth overridden/augmented")
                    if DEBUG & DEBUG::autolexer;
                last UP;
            }
        } 

        $self->deb("\treusing ($key, $realkey, $lang, $super).") if DEBUG & DEBUG::autolexer;
        return $superlexer;
    }

    my $dba = $ast->{dba};

    my $d = DEBUG & DEBUG::autolexer;
    print ::LOG "generating DFA lexer for $key -->\n" if $d;
    my $nfa;

    if ($key =~ /(.*):\*$/) {
        my $proto = $1;
        $dba = $proto;
        my $protopat = $1 . '__S_';
        my $protolen = length($protopat);
        my @alts;
        my $j = 0;
        my @stack = $lang;

        while (@stack) {
            no strict 'refs';
            my $class = pop @stack;
            push @stack, reverse @{ $class . "::ISA" };