Benchmark-Perl-Formance-Cargo
view release on metacpan or search on metacpan
share/P6STD/CursorBase.pmc view on Meta::CPAN
our $YELLOW = color 'yellow';
our $RED = color 'red';
our $CLEAR = color 'clear';
use LazyMap qw(lazymap eager);
use constant DEBUG => $::DEBUG;
our $REGEXES = { ALL => [] };
BEGIN {
require Moose;
# this prevents us from inheriting from Moose::Object, which saves a
# good 20 seconds on DESTROY/DEMOLISHALL
Moose::Meta::Class->create('CursorBase');
}
our $data_dir;
BEGIN {
# 2 possibilities:
# * STD is installed. CursorBase will be in the system @INC somewhere,
# with nothing but other modules besides it. Use File::ShareDir.
# * STD is being used in place. uniprops will be in the same dir as
# CursorBase.pm
# yes, the INC entry always uses forward slashes and ends in .pm, always
my $path = __PACKAGE__;
$path =~ s#::#/#g;
$data_dir = File::Basename::dirname($INC{"$path.pm"});
if (! -e File::Spec->catfile($data_dir, "uniprops")) {
$data_dir = File::ShareDir::dist_dir('STD');
}
}
$::PERL6HERE = $ENV{PERL6HERE} // 'â';
Encode::_utf8_on($::PERL6HERE);
binmode(STDIN, ":utf8");
binmode(STDERR, ":utf8");
binmode(STDOUT, ":utf8");
BEGIN {
if ($^P || !DEBUG) {
open(::LOG, ">&1") or die "Cannot create $0.log: $!";
}
else {
open(::LOG, ">$0.log") or die "Cannot create $0.log: $!";
}
binmode(::LOG, ":utf8");
}
#############################################################
# Cursor Accessors
#############################################################
sub _PARAMS {} # overridden in parametric role packages
sub from :lvalue { $_[0]->{_from} //= $_[0]->{_pos} }
sub to { $_[0]->{_pos} }
sub pos :lvalue { $_[0]->{_pos} }
sub chars { $_[0]->{_pos} - ($_[0]->{_from} // $_[0]->{_pos}) }
sub Str { no warnings; exists $_[0]->{_from} && defined $_[0]->{_pos} ? substr($::ORIG, $_[0]->{_from}, $_[0]->{_pos} - $_[0]->{_from})//'' : '' }
sub xact { $_[0]->{_xact} // die "internal error: cursor has no xact!!!" }
sub orig { $::ORIG }
sub WHAT { ref $_[0] || $_[0] }
sub item { $_[0] }
sub caps { $_[0] && $_[0]->{'~CAPS'} ? @{$_[0]->{'~CAPS'}} : () }
sub chunks { die "unimpl" }
sub ast { exists $_[0]->{'_ast'} ? $_[0]->{'_ast'} : $_[0]->Str }
sub make { $_[0]->{'_ast'} = $_[1]; $_[0] }
sub label_id {
bless { 'file' => $::FILE->{name}, 'pos' => $_[0]->{_pos} }, 'LABEL';
}
sub list { my $self = shift;
my @result;
# can't just do this in numerical order because some might be missing
# and we don't know the max
for my $k (keys %$self) {
$result[$k] = $self->{$k} if $k =~ /^\d/;
}
\@result;
}
sub hash { my $self = shift;
my %result;
for my $k (keys %$self) {
$result{$k} = $self->{$k} if $k !~ /^[_\d~]/;
}
\%result;
}
sub deb { my $self = shift;
my $pos = ref $self && defined $self->{_pos} ? $self->{_pos} : "?";
print ::LOG $pos,'/',$self->lineof($pos), "\t", $CTX, ' ', @_, "\n";
}
sub clean {
my $self = shift;
delete $self->{_fate};
delete $self->{_pos}; # EXPR blows up without this for some reason
delete $self->{_reduced};
for my $k (values %$self) {
next unless ref $k;
if (ref $k eq 'ARRAY') {
for my $k2 (@$k) {
eval {
$k2->clean if ref $k2;
}
}
}
else {
eval {
$k->clean;
}
}
}
$self;
}
sub dump {
share/P6STD/CursorBase.pmc view on Meta::CPAN
$result;
}
sub you_are_here {
my $self = shift;
$::YOU_WERE_HERE = $::CURLEX;
$self;
}
sub you_were_here {
my $self = shift;
my $all;
# setting?
if ($::YOU_WERE_HERE) {
$all = $STD::ALL;
$all->{SETTING} = $::YOU_WERE_HERE;
$all->{CORE} = $::YOU_WERE_HERE if $::UNIT->{'$?LONGNAME'} eq 'CORE';
}
else {
eval { $::UNIT->{'$?SETTING_ID'} = $STD::ALL->{SETTING}->id };
warn $@ if $@;
eval { $::UNIT->{'$?CORE_ID'} = $STD::ALL->{CORE}->id };
warn $@ if $@;
$all = {};
for my $key (keys %{$STD::ALL}) {
next if $key =~ /^MY:file<\w+\.setting>/ or $key eq 'CORE' or $key eq 'SETTING';
$all->{$key} = $STD::ALL->{$key};
}
}
$self->sys_save_syml($all);
$self;
}
sub delete {
my $self = shift;
delete $self->{@_};
}
{ package Match;
sub new { my $self = shift;
my %args = @_;
bless \%args, $self;
}
sub from { my $self = shift;
$self->{_f};
}
sub to { my $self = shift;
$self->{_t};
}
}
#############################################################
# Cursor transformations
#############################################################
sub cursor_xact {
if (DEBUG & DEBUG::cursors) {
my $self = shift;
my $name = shift;
my $pedigree = '';
for (my $x = $self->{_xact}; $x; $x = $x->[-1]) {
my $n = $x->[0];
$n =~ s/^RULE // or
$n =~ s/^ALT *//;
$pedigree .= ($x->[-2] ? " - " : " + ") . $n;
}
$self->deb("cursor_xact $name$pedigree");
$self->{_xact} = [$name,0,$self->{_xact}];
return $self;
}
# doing this in place is slightly dangerous, but seems to work
$_[0]->{_xact} = [$_[1],0,$_[0]->{_xact}];
return $_[0];
}
sub cursor_fresh { my $self = shift;
my %r;
my $lang = @_ && $_[0] ? shift() : ref $self;
$self->deb("cursor_fresh lang $lang") if DEBUG & DEBUG::cursors;
@r{'_pos','_fate','_xact'} = @$self{'_pos','_fate','_xact'};
$r{_herelang} = $self->{_herelang} if $self->{_herelang};
bless \%r, ref $lang || $lang;
}
sub cursor_herelang { my $self = shift;
$self->deb("cursor_herelang") if DEBUG & DEBUG::cursors;
my %r = %$self;
$r{_herelang} = $self;
bless \%r, 'STD::Q';
}
sub prepbind {
my $self = shift;
delete $self->{_fate};
delete $_->{_xact} for @_;
$self;
}
sub cursor_bind { my $self = shift; # this is parent's match cursor
my $bindings = shift;
my $submatch = shift; # this is the submatch's cursor
$self->prepbind($submatch);
$self->deb("cursor_bind @$bindings") if DEBUG & DEBUG::cursors;
my @caps;
@caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
my %r = %$self;
if ($bindings) {
for my $binding (@$bindings) {
if (ref $r{$binding} eq 'ARRAY') {
push(@{$r{$binding}}, $submatch);
}
else {
$r{$binding} = $submatch;
}
next if $binding eq 'PRE';
next if $binding eq 'POST';
push @caps, $binding, $submatch;
}
$r{'~CAPS'} = \@caps;
}
$submatch->{_from} = $r{_from} = $r{_pos};
$r{_pos} = $submatch->{_pos};
$r{_xact} = $self->{_xact};
bless \%r, ref $self; # return new match cursor for parent
}
sub cursor_bind_value { my $self = shift; # this is parent's match cursor
my $binding = shift;
my $value = shift;
delete $self->{_fate};
$self->deb("cursor_bind_value $binding") if DEBUG & DEBUG::cursors;
my @caps;
@caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
my %r = %$self;
if (ref $r{$binding} eq 'ARRAY') {
push(@{$r{$binding}}, $value);
}
else {
$r{$binding} = $value;
}
push @caps, $binding, $value
unless $binding eq 'PRE' or $binding eq 'POST';
$r{'~CAPS'} = \@caps;
$r{_xact} = $self->{_xact};
bless \%r, ref $self; # return new match cursor for parent
}
sub cursor_fate { my $self = shift;
my $pkg = shift;
my $name = shift;
my $retree = shift;
# $_[0] is now ref to a $trystate;
$self->deb("cursor_fate $pkg $name") if DEBUG & DEBUG::cursors;
my $key = refaddr($retree->{$name}) // $name;
my $lexer = $::LEXERS{ref $self}->{$key} // do {
local %::AUTOLEXED;
$self->_AUTOLEXpeek($name,$retree);
};
if ($self->{_pos} >= $::HIGHWATER) {
if ($self->{_pos} > $::HIGHWATER) {
%$::HIGHEXPECT = ();
$::HIGHMESS = '';
}
$::HIGHEXPECT->{$lexer->{DBA}}++;
$::HIGHWATER = $self->{_pos};
}
my $P = $self->{_pos};
if ($P > @::ORIG) {
return sub {};
}
$self->cursor_fate_dfa($pkg, $name, $lexer, $P);
}
sub cursor_fate_dfa {
my ($self, $pkg, $name, $lexer, $P) = @_;
my $state = $lexer->{S};
my $p = $P;
my @rfates;
print ::LOG "=" x 10,"\n$p DFA for ${pkg}::$name in ", ref $self, "\n" if DEBUG & DEBUG::autolexer;
CH: {
push @rfates, @{ $state->[0] // _jit_dfa_node($lexer, $state) };
if (DEBUG & DEBUG::autolexer) {
for (@{ $state->[0] }) {
my @b;
for (my $f = $_; $f; $f = $f->[0]) {
push @b, @{$f}[1,2];
}
print ::LOG " [adding fate @b]\n";
}
}
last if $p == @::ORIG;
my $chi = $::ORIG[$p++];
print ::LOG "--- ", pack("U", $chi), "\n" if DEBUG & DEBUG::autolexer;
if ($state->[1]{$chi}) {
$state = $state->[1]{$chi};
print ::LOG "specific -> ", $state->[1]{ID}, "\n"
if DEBUG & DEBUG::autolexer;
redo;
}
my $dt = $state->[2];
while (defined $dt) {
if (ref $dt eq 'ARRAY') {
if (DEBUG & DEBUG::autolexer) {
print ::LOG $dt->[2][-1],
(vec($dt->[2][$chi >> 10], $chi & 1023, 1) ?
"? yes\n" : "? no\n");
}
$dt = $dt->[vec($dt->[2][$chi >> 10], $chi & 1023, 1)];
} else {
print ::LOG " -> ", $$dt->[1]{ID}, "\n" if DEBUG & DEBUG::autolexer;
$state = $state->[1]{$chi} = $$dt;
redo CH;
}
}
}
sub { @rfates ? pop(@rfates) : () };
}
sub cursor_all { my $self = shift;
my $fpos = shift;
my $tpos = shift;
$self->deb("cursor_all from $fpos to $tpos") if DEBUG & DEBUG::cursors;
my %r = %$self;
@r{'_from','_pos'} = ($fpos,$tpos);
bless \%r, ref $self;
}
sub makestr { my $self = shift;
$self->deb("maketext @_") if DEBUG & DEBUG::cursors;
my %r = @_;
bless \%r, "Str";
}
sub cursor_tweak { my $self = shift;
my $tpos = shift;
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");
}
$self->{_pos} = $tpos;
return () if $tpos > @::ORIG;
$self;
}
sub cursor_incr { my $self = shift;
my $tpos = $self->{_pos} + 1;
$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");
}
$self->{_pos} = $tpos;
return () if $tpos > @::ORIG;
$self;
}
sub cursor { 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} = $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");
my $xact = $C->xact;
lazymap(sub { $_[0]->retm() },
$C->cursor($pos),
LazyMap->new(sub { $C->_PLUSf($_[0]) }, $block));
}
sub _STARg { 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("STARg $pos");
# my $xact = $C->xact;
lazymap(sub { $_[0]->retm() }, reverse
eager(
$C->cursor($self->{_pos}),
$C->_PLUSf($block))
);
}
sub _STARr { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $pos = $self->{_pos};
my $prev = $self->cursor_xact("STARr $pos");
# my $xact = $prev->xact;
my $prev_pos = $prev->{_pos} // 0;
my @all;
my $eos = @::ORIG;
for (;;) {
last if $prev->{_pos} == $eos;
my @matches = $block->($prev); # XXX shouldn't read whole list
# say @matches.perl;
last unless @matches;
my $first = $matches[0]; # no backtracking into block on ratchet
last if $first->{_pos} == $prev_pos;
$prev_pos = $first->{_pos};
push @all, $first;
$prev = $first;
}
$self->cursor($prev_pos)->retm();
}
sub _PLUSf { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $pos = $self->{_pos};
my $x = $self->cursor_xact("PLUSf $pos");
my $xact = $x->xact;
# don't go beyond end of string
return () if $self->{_pos} == @::ORIG;
lazymap(
sub {
my $x = $_[0];
lazymap(
sub {
$self->cursor($_[0]->{_pos})->retm()
}, $x, LazyMap->new(sub { $x->_PLUSf($_[0]) }, $block)
);
}, $block->($self)
);
}
sub _PLUSg { 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("PLUSg $pos");
# my $xact = $C->xact;
reverse eager($C->_PLUSf($block, @_));
}
sub _PLUSr { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my @all;
my $eos = @::ORIG;
my $pos = $self->{_pos};
my $to = $self->cursor_xact("PLUSr $pos");
# my $xact = $to->xact;
for (;;) {
last if $to->{_pos} == $eos;
my @matches = $block->($to); # XXX shouldn't read whole list
last unless @matches;
my $first = $matches[0]; # no backtracking into block on ratchet
#$first->deb($matches->perl) if DEBUG;
push @all, $first;
$to = $first;
}
return () unless @all;
$self->cursor($to->{_pos})->retm();
}
sub _REPSEPf { my $self = shift;
my $sep = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my @result;
# don't go beyond end of string
return () if $self->{_pos} == @::ORIG;
my $pos = $self->{_pos};
my $C = $self->cursor_xact("REPSEPf $pos");
# my $xact = $C->xact;
do {
for my $x ($block->($C)) {
for my $s ($sep->($x)) {
push @result, lazymap(sub { $C->cursor($_[0]->{_pos}) }, $x, $s->_REPSEPf($sep,$block));
}
}
};
lazymap(sub { $_[0]->retm() }, @result);
}
sub _REPSEPg { my $self = shift;
my $sep = 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("REPSEPg $pos");
# my $xact = $C->xact;
reverse eager($C->_REPSEPf($sep, $block, @_));
}
sub _REPSEPr { my $self = shift;
my $sep = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my @all;
my $eos = @::ORIG;
my $pos = $self->{_pos};
my $to = $self->cursor_xact("REPSEPr $pos");
# my $xact = $C->xact;
for (;;) {
last if $to->{_pos} == $eos;
my @matches = $block->($to); # XXX shouldn't read whole list
last unless @matches;
my $first = $matches[0]; # no backtracking into block on ratchet
#$first->deb($matches->perl) if DEBUG;
push @all, $first;
my @seps = $sep->($first);
last unless @seps;
my $sep = $seps[0];
$to = $sep;
}
return () unless @all;
$self->cursor($all[-1]->{_pos})->retm;
}
sub _OPTr { 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("OPTr $pos");
my $xact = $C->xact;
my $x = ($block->($C))[0];
my $r = $x // $C->cursor_tweak($pos);
$r->{_xact} = $self->{_xact};
$r->retm();
}
sub _OPTg { 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("OPTg $pos");
# my $xact = $C->xact;
my @x = $block->($C);
lazymap(sub { $_[0]->retm() },
$block->($C),
$self->cursor($pos));
}
sub _OPTf { 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("OPTf $pos");
# my $xact = $C->xact;
lazymap(sub { $_[0]->retm() },
$C->cursor($C->{_pos}),
$block->($self));
}
sub _BRACKET { my $self = shift;
my $block = shift;
no warnings 'recursion';
my $oldlang = ref($self);
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
lazymap(sub { bless($_[0],$oldlang)->retm() },
$block->($self));
}
sub _BRACKETr { my $self = shift;
my $block = shift;
no warnings 'recursion';
my $oldlang = ref($self);
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my ($val) = $block->($self) or return ();
bless($val,$oldlang)->retm();
}
sub _PAREN { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
lazymap(sub { $_[0]->retm() },
$block->($self));
}
sub _NOTBEFORE { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
local $::HIGHEXPECT = {}; # don't count lookahead as expectation
local $::HIGHWATER = $::HIGHWATER;
my @caps;
@caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
my @all = $block->($self);
return () if @all;
$self->{'~CAPS'} = \@caps;
return $self->cursor($self->{_pos})->retm();
}
sub _NOTCHAR { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my @all = $block->($self);
return () if @all;
return $self->cursor($self->{_pos}+1)->retm();
}
sub before { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
local $::HIGHEXPECT = {}; # don't count lookahead as expectation
local $::HIGHWATER = $::HIGHWATER;
my @caps;
@caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
my @all = $block->($self);
if (@all and $all[0]) {
$all[0]->{'~CAPS'} = \@caps;
if ($self->{_ast}) {
$all[0]->{'_ast'} = $self->{_ast};
}
else {
delete $all[0]->{'_ast'};
}
return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
}
return ();
}
sub suppose { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
local $::FATALS = 0;
local @::WORRIES;
local %::WORRIES;
local $::HIGHWATER = -1;
local $::HIGHMESS;
local $::HIGHEXPECT = {};
local $::IN_SUPPOSE = 1;
my @all;
eval {
@all = $block->($self);
};
lazymap( sub { $_[0]->retm() }, @all );
}
sub after { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
local $::HIGHEXPECT = {}; # don't count lookbehind as expectation
my $end = $self->cursor($self->{_pos});
my @caps;
@caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
my @all = $block->($end); # Make sure $_->{_from} == $_->{_pos}
if (@all and $all[0]) {
$all[0]->{'~CAPS'} = \@caps;
if ($self->{_ast}) {
$all[0]->{'_ast'} = $self->{_ast};
}
else {
delete $all[0]->{'_ast'};
}
return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
}
return ();
}
sub null { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
return $self->cursor($self->{_pos})->retm();
}
sub ws__PEEK { ''; }
sub ws {
my $self = shift;
local $CTX = $self->callm() if DEBUG & DEBUG::trace_call;
my @stub = return $self if exists $::MEMOS[$self->{_pos}]{ws};
my $S = $self->{_pos};
my $C = $self->cursor_xact("RULE ws $S");
# my $xact = $C->xact;
$::MEMOS[$S]{ws} = undef; # exists means we know, undef means no ws before here
$self->_MATCHIFY($S, 'ws',
$C->_BRACKET( sub { my $C=shift;
do { my @gather;
push @gather, (map { my $C=$_;
(map { my $C=$_;
(map { my $C=$_;
$C->_NOTBEFORE( sub { my $C=shift;
$C
})
} $C->_COMMITRULE())
} $C->before(sub { my $C=shift;
$C->_ALNUM()
}))
} $C->before( sub { my $C=shift;
$C->after(sub { my $C=shift;
$C->_ALNUM_rev()
})
}))
or
push @gather, (map { my $C=$_;
(map { my $C=$_;
scalar(do { $::MEMOS[$C->{_pos}]{ws} = $S unless $C->{_pos} == $S }, $C)
} $C->_STARr(sub { my $C=shift;
$C->_SPACE()
}))
} $C);
@gather;
}
})
);
}
sub _ASSERT { my $self = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my @all = $block->($self);
if ((@all and $all[0]->{_bool})) {
return $self->cursor($self->{_pos})->retm();
}
return ();
}
sub _BINDVAR { my $self = shift;
my $var = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
lazymap(sub { $$var = $_[0]; $_[0]->retm() },
$block->($self));
}
sub _SUBSUME { my $self = shift;
my $names = shift;
my $block = shift;
no warnings 'recursion';
no warnings 'recursion';
local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
lazymap(sub { $self->cursor_bind($names, $_[0])->retm() },
$block->($self->cursor_fresh()));
}
sub _SUBSUMEr { my $self = shift;
my $names = shift;
my $block = shift;
no warnings 'recursion';
no warnings 'recursion';
local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
my ($var) = $block->($self->cursor_fresh()) or return ();
$self->cursor_bind($names, $var)->retm();
}
sub _SUBSUMEblock { my $self = shift;
my $name = shift;
my $block = shift;
no warnings 'recursion';
local $CTX = $self->callm($name) if DEBUG & DEBUG::trace_call;
$self->cursor_bind_value($name, $block->($self))->retm();
}
sub _EXACT_rev { my $self = shift;
my $s = shift() // '';
my @ints = unpack("U*", $s);
local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
while (@ints) {
return () unless ($::ORIG[--$P]//-1) == pop @ints;
}
return $self->cursor($P)->retm();
}
sub _EXACT { my $self = shift;
my $s = shift() // '';
my @ints = unpack("U*", $s);
local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
while (@ints) {
return () unless ($::ORIG[$P++]//-1) == shift @ints;
}
return $self->cursor($P)->retm();
# if (substr($::ORIG, $P, $len) eq $s) {
# $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
# my $r = $self->cursor($P+$len);
# $r->retm();
# }
# else {
# $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
# return ();
# }
}
sub _PATTERN { my $self = shift;
my $qr = shift;
local $CTX = $self->callm($qr) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
pos($::ORIG) = $P;
if ($::ORIG =~ /$qr/gc) {
my $len = pos($::ORIG) - $P;
$self->deb("PATTERN $qr matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
my $r = $self->cursor($P+$len);
$r->retm();
}
else {
$self->deb("PATTERN $qr didn't match at $P") if DEBUG & DEBUG::matchers;
return ();
}
}
sub _BACKREFn { my $self = shift;
my $n = shift;
local $CTX = $self->callm($n) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
my $s = $self->{$n}->Str;
my $len = length($s);
if (substr($::ORIG, $P, $len) eq $s) {
$self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
my $r = $self->cursor($P+$len);
$r->retm();
}
else {
$self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
return ();
}
}
sub _SYM { my $self = shift;
my $s = shift;
my $i = shift;
$s = $s->[0] if ref $s eq 'ARRAY';
local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
my $len = length($s);
if ($i
? lc substr($::ORIG, $P, $len) eq lc $s
: substr($::ORIG, $P, $len) eq $s
) {
$self->deb("SYM $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
my $r = $self->cursor($P+$len);
$r->{sym} = $s;
$r->retm();
}
else {
$self->deb("SYM $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
return ();
}
}
#sub _EXACT_rev { my $self = shift;
# my $s = shift;
#
# local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
# my $len = length($s);
# my $from = $self->{_pos} - $len;
# if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) {
# my $r = $self->cursor_rev($from);
# $r->retm();
# }
# else {
## say "EXACT_rev $s didn't match @{[substr($!orig,$from,$len)]} at $from $len";
# return ();
# }
#}
sub _ARRAY { my $self = shift;
local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos} // 0;
my @array = sort { length($b) <=> length($a) } @_; # XXX suboptimal
my @result = ();
for my $s (@array) {
my $len = length($s);
if (substr($::ORIG, $P, $len) eq $s) {
$self->deb("ARRAY elem $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
my $r = $self->cursor($P+$len);
push @result, $r->retm('');
}
}
return @result;
}
sub _ARRAY_rev { my $self = shift;
local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
my @array = sort { length($b) <=> length($a) } @_; # XXX suboptimal
my @result = ();
for my $s (@array) {
my $len = length($s);
my $from = $self->{_pos} = $len;
if (substr($::ORIG, $from, $len) eq $s) {
$self->deb("ARRAY_rev elem $s matched @{[substr($::ORIG,$from,$len)]} at $from $len") if DEBUG & DEBUG::matchers;
my $r = $self->cursor_rev($from);
push @result, $r->retm('');
}
}
return @result;
}
sub _DIGIT { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /^\d$/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "DIGIT didn't match $char at $P";
return ();
}
}
sub _DIGIT_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "DIGIT_rev didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^\d$/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "DIGIT_rev didn't match $char at $from";
return ();
}
}
sub ww { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
return () unless $P;
my $chars = substr($::ORIG, $P-1, 2);
if ($chars =~ /^\w\w$/) {
my $r = $self->cursor($P);
return $r->retm();
}
else {
# say "ww didn't match $chars at $P";
return ();
}
}
sub _ALNUM { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /^\w$/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "ALNUM didn't match $char at $P";
return ();
}
}
sub _ALNUM_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "ALNUM_rev didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^\w$/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "ALNUM_rev didn't match $char at $from";
return ();
}
}
my $alpha;
BEGIN {
$alpha = "";
for my $ch (0..255) {
my $char = chr($ch);
vec($alpha,$ch,1) = 1 if $char =~ /\w/ and $char !~ /\d/;
}
}
sub alpha { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
# my $char = substr($::ORIG, $P, 1);
my $ch = $::ORIG[$P];
if (vec($alpha,$ch,1) or ($ch > 255 and chr($ch) =~ /\pL/)) {
# if ($char =~ /^[_[:alpha:]\pL]$/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "alpha didn't match $char at $P";
return ();
}
}
sub alpha_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^[_[:alpha:]\pL]$/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
return ();
}
}
sub _SPACE { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /^\s$/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "SPACE didn't match $char at $P";
return ();
}
}
sub _SPACE_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "SPACE_rev didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^\s$/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "SPACE_rev didn't match $char at $from";
return ();
}
}
sub _HSPACE { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "HSPACE didn't match $char at $P";
return ();
}
}
sub _HSPACE_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "HSPACE_rev didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "HSPACE_rev didn't match $char at $from";
return ();
}
}
sub _VSPACE { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "VSPACE didn't match $char at $P";
return ();
}
}
sub _VSPACE_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "VSPACE_rev didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "VSPACE_rev didn't match $char at $from";
return ();
}
}
sub _CCLASS { my $self = shift;
my $cc = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
my $char = substr($::ORIG, $P, 1);
if ($char =~ /$cc/) {
my $r = $self->cursor($P+1);
return $r->retm();
}
else {
# say "CCLASS didn't match $char at $P";
return ();
}
}
sub _CCLASS_rev { my $self = shift;
my $cc = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
# say "CCLASS didn't match $char at $from";
return ();
}
my $char = substr($::ORIG, $from, 1);
if ($char =~ /$cc/) {
my $r = $self->cursor_rev($from);
return $r->retm();
}
else {
# say "CCLASS didn't match $char at $from";
return ();
}
}
sub _ANY { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
if ($P < @::ORIG) {
$self->cursor($P+1)->retm();
}
else {
# say "ANY didn't match anything at $P";
return ();
}
}
sub _ANY_rev { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $from = $self->{_pos} - 1;
if ($from < 0) {
return ();
}
return $self->cursor_rev($from)->retm();
}
sub _BOS { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
if ($P == 0) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _BOS_rev { $_[0]->_BOS }
sub _BOL { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
if ($P == 0 or substr($::ORIG, $P-1, 1) =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _BOL_rev { $_[0]->_BOL }
sub _EOS { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
if ($P == @::ORIG) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _EOS_rev { $_[0]->_EOS }
sub _EOL { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
if ($P == @::ORIG or substr($::ORIG, $P, 1) =~ /^(?:\r\n|[\n\f\x0b\x{2028}\x{2029}])$/) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _EOL_rev { $_[0]->_EOL }
sub _RIGHTWB { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
pos($::ORIG) = $P - 1;
if ($::ORIG =~ /\w\b/) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _RIGHTWB_rev { $_[0]->_RIGHTWB }
sub _LEFTWB { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
pos($::ORIG) = $P;
if ($::ORIG =~ /\b(?=\w)/) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _LEFTWB_rev { $_[0]->_LEFTWB }
sub _LEFTRESULT { my $self = shift;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
pos($::ORIG) = $P;
if ($::ORIG =~ /\b(?=\w)/) {
$self->cursor($P)->retm();
}
else {
return ();
}
}
sub _LEFTRESULT_rev { $_[0]->_LEFTWB }
sub _REDUCE { my $self = shift;
my $S = shift;
my $meth = shift;
my $key = $meth;
$key .= ' ' . $_[0] if @_;
$self->{_reduced} = $key;
$self->{_from} = $S;
if ($::ACTIONS) {
eval { $::ACTIONS->$meth($self, @_) };
warn $@ if $@ and not $@ =~ /locate object method "\Q$meth/;
}
$self->deb("REDUCE $key from " . $S . " to " . $self->{_pos}) if DEBUG & DEBUG::matchers;
$self;
}
sub _COMMITBRANCH { my $self = shift;
my $xact = $self->xact;
# $self->{LAST} = shift() if @_;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
while ($xact) {
$xact->[-2] = 1;
$self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
return $self->cursor_xact("CB") if $xact->[0] =~ /^ALT/;
$xact = $xact->[-1];
}
die "Not in an alternation, so can't commit to a branch";
}
sub _COMMITLTM { my $self = shift;
my $xact = $self->xact;
# $self->{LAST} = shift() if @_;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
while ($xact) {
$xact->[-2] = 1;
$self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
return $self->cursor_xact("CL") if $xact->[0] =~ /^ALTLTM/;
$xact = $xact->[-1];
}
die "Not in a longest token matcher, so can't commit to a longest token";
}
sub _COMMITRULE { my $self = shift;
my $xact = $self->xact;
# $self->{LAST} = shift() if @_;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
while ($xact) {
$xact->[-2] = 1;
$self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
return $self->cursor_xact("CR") if $xact->[0] =~ /^RULE/;
$xact = $xact->[-1];
}
die "Not in a rule, so can't commit to rule";
}
sub commit { my $self = shift;
my $xact = $self->xact;
# $self->{LAST} = shift() if @_;
local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
my $P = $self->{_pos};
while ($xact) {
$xact->[-2] = 1;
$self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
return $self->cursor_xact("CM") if $xact->[0] =~ /^MATCH/;
$xact = $xact->[-1];
}
die "Not in a match, so can't commit to match";
}
sub fail { my $self = shift;
my $m = shift;
return ();
}
sub bless { CORE::bless $_[1], $_[0]->WHAT }
#############################################################
# JIT lexer generator
#############################################################
## NFA structure:
## array of (NFA node) ->
## 0: non extensible (imperative) flag
## 0: array of fate (array of fate element)
## array of (label) at odd index, new index at even
## DFA structure:
## each DFA node is array:
## 0: array of object fates
## 1: hash of specific cases (char => DFAnode)
## also carries some debug data
## 2n: reference to a uniprop hash
## 2n+1: DFAnode is that hash existed
## Labels: undef is epsilon link.
## otherwise list - 1 positive, 0+ negative
## each is: 1 character, else unicode prop in "Gc/L" form
## "DFA" lexer structure:
## {DFA} -> array of refs to all DFA nodes
## {DBA}, {FILE}, {NAME} same as "RE" lexer structure
## {S} -> ref to DFA root
## {NFA} -> NFA structure
## individual fates in the NFA end with a hook which can be 1 to stop adding
## fates on the end; it's not always possible to associate a unique fate with
## each NFA node, consider (a|b)*
## A NFA or DFA node is accepting if it has a nonempty list of fates
#cycle breaker
{
package CursorBase::dfa;
sub DESTROY {
my $self = shift;
for (@$self) { @$_ = (); }
}
}
# Steal data from Perl5's Unicode maps
my %unicode_map_cache;
BEGIN {
$unicode_map_cache{ALL} = [scalar("\377" x 128) x 1088, "ALL"] ;
my $name = File::Spec->catfile($data_dir, "uniprops");
open MAP, "<", "$name" or
die "cannot open unicode maps from $name : $!\n";
binmode MAP;
while (defined (my $c = getc MAP)) {
share/P6STD/CursorBase.pmc view on Meta::CPAN
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" };
my @methods = @{ _scan_regexes($class, $proto) // [] };
for my $method (@methods) {
my $callname = $class . '::' . $method;
$method = substr($method, 0, length($method)-6);
my $peeklex = $self->$callname();
die "$proto has no lexer!?" unless $peeklex->{NFAT};
push @alts, ["${class}::$method", $peeklex->{NFAT}];
}
}
$nfa = nfa::method($proto, nfa::ltm($proto, @alts));
} elsif ($ast) {
$nfa = $ast->nfa($self);
} else {
die "BAD KEY";
}
die "dba unspecified" unless $dba;
share/P6STD/CursorBase.pmc view on Meta::CPAN
$text =~ s/^\((.*)\)$/$1/;
}
if ($traitname eq 'export') {
if (defined $text) {
$text =~ s/://g;
}
else {
$text = 'DEFAULT';
}
$self->set_export($text);
$text;
}
elsif (defined $text) {
$text;
}
else {
1;
}
}
sub set_export {
my $self = shift;
my $text = shift;
my $textpkg = $text . '::';
my $name = $::DECLARAND->{name};
my $xlex = $STD::ALL->{ ($::DECLARAND->{inlex})->[0] };
$::DECLARAND->{export} = $text;
my $sid = $::CURLEX->idref;
my $x = $xlex->{'EXPORT::'} //= Stash::->new( 'PARENT::' => $sid, '!id' => [$sid->[0] . '::EXPORT'] );
$x->{$textpkg} //= Stash::->new( 'PARENT::' => $x->idref, '!id' => [$sid->[0] . '::EXPORT::' . $text] );
$x->{$textpkg}->{$name} = $::DECLARAND;
$x->{$textpkg}->{'&'.$name} = $::DECLARAND
if $name =~ /^\w/ and $::IN_DECL ne 'constant';
$self;
}
sub mixin {
my $self = shift;
my $WHAT = ref($self)||$self;
my @mixins = @_;
my $NEWWHAT = $WHAT . '::';
my @newmix;
for my $mixin (@mixins) {
my $ext = ref($mixin) || $mixin;
push @newmix, $ext;
$ext =~ s/(\w)\w*::/$1/g; # just looking for a "cache" key, really
$NEWWHAT .= '_X_' . $ext;
}
$self->deb("mixin $NEWWHAT from $WHAT @newmix") if DEBUG & DEBUG::mixins;
no strict 'refs';
if (not exists &{$NEWWHAT.'::meta'}) { # never composed this one yet?
# fake up mixin with MI, being sure to put "roles" in front
my $eval = "package $NEWWHAT; use Moose ':all' => { -prefix => 'moose_' }; moose_extends('$WHAT'); moose_with(" . join(',', map {"'$_'"} @newmix) . ");our \$CATEGORY = '.';\n";
$self->deb($eval) if DEBUG & DEBUG::mixins;
local $SIG{__WARN__} = sub { die $_[0] unless $_[0] =~ /^Deep recursion/ };
eval $eval;
warn $@ if $@;
}
return $self->cursor_fresh($NEWWHAT);
}
sub tweak {
my $self = shift;
my $class = ref $self;
no strict 'refs';
for (;;) {
my $retval = eval {
$self->deb("Calling $class" . '::multitweak') if DEBUG & DEBUG::mixins;
&{$class . '::multitweak'}($self,@_);
};
return $retval if $retval;
die $@ unless $@ =~ /^NOMATCH|^Undefined subroutine/;
last unless $class =~ s/(.*)::.*/$1/;
}
}
# only used for error reporting
sub clean_id { my $self = shift;
my ($id,$name) = @_;
my $file = $::FILE->{name};
$id .= '::';
$id =~ s/^MY:file<CORE.setting>.*?::/CORE::/;
$id =~ s/^MY:file<\w+.setting>.*?::/SETTING::/;
$id =~ s/^MY:file<\Q$file\E>$/UNIT/;
$id =~ s/:pos\(\d+\)//;
$id .= "<$name>";
$id;
}
# remove consistent leading whitespace (mutates text nibbles in place)
sub trim_heredoc { my $doc = shift;
my ($stopper) = $doc->stopper or
$doc->panic("Couldn't find delimiter for heredoc\n");
my $ws = $stopper->{ws}->Str;
return $stopper if $ws eq '';
my $wsequiv = $ws;
$wsequiv =~ s{^(\t+)}[' ' x (length($1) * ($::TABSTOP // 8))]xe;
# We can't use ^^ after escapes, since the escape may be mid-line
# and we'd get false positives. Use a fake newline instead.
$doc->{nibbles}[0] =~ s/^/\n/;
for (@{$doc->{nibbles}}) {
next if ref $_; # next unless $_ =~ Str;
# prefer exact match over any ws
s{(?<=\n)(\Q$ws\E|[ \t]+)}{
my $white = $1;
if ($white eq $ws) {
'';
}
else {
$white =~ s[^ (\t+) ][ ' ' x (length($1) * ($::TABSTOP // 8)) ]xe;
if ($white =~ s/^\Q$wsequiv\E//) {
$white;
}
share/P6STD/CursorBase.pmc view on Meta::CPAN
else {
$coercion = 'named_unary';
}
}
elsif ($name =~ /^postfix:/) {
$coercion = 'methodcall';
}
elsif ($name =~ /^circumfix:/) {
$coercion = 'term';
}
elsif ($name =~ /^postcircumfix:/) {
$coercion = 'methodcall';
}
elsif ($name =~ /^term:/) {
$coercion = 'term';
}
state $genpkg = 'ANON000';
$genpkg++;
my $e;
if (@list == 0) {
$lang->panic('Null operator is not allowed');
}
elsif (@list == 1) {
$e = <<"END";
package $genpkg;
use Moose ':all' => { -prefix => 'moose_' };
moose_extends('$WHAT');
# $rule
my \$retree = {
'$mangle' => bless({
'dba' => '$category expression',
'kind' => 'token',
'min' => 12345,
're' => bless({
'a' => 0,
'i' => 0,
'min' => 12345,
'name' => 'sym',
'rest' => '',
'sym' => $sym,
}, 'RE_method'),
}, 'RE_ast'),
};
our \$CATEGORY = '$category';
sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
sub $mangle {
my \$self = shift;
local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
my %args = \@_;
my \$sym = \$args{sym} // $sym;
my \$xact = ['RULE $mangle', 0, \$::XACT];
local \$::XACT = \$xact;
my \$S = \$self->{_pos};
my \$C = \$self->cursor_xact("RULE $mangle \$S");
# my \$xact = \$C->xact;
\$C->{'sym'} = \$sym;
\$self->_MATCHIFY(\$S, '$mangle',
do {
if (my (\$C) = (\$C->_SYM(\$sym, 0))) {
\$C->_SUBSUMEr(['O'], sub {
my \$C = shift;
\$C->O(%STD::$coercion)
});
}
else {
();
}
}
);
}
1;
END
}
else {
for (@list) {
if (/'/) {
s/(.*)/"$1"/;
}
else {
s/(.*)/'$1'/;
}
}
my $starter = $list[0];
my $stopper = $list[1];
$e = <<"END";
package $genpkg;
use Moose ':all' => { -prefix => 'moose_' };
moose_extends('$WHAT');
# $rule
my \$retree = {
'$mangle' => bless({
'dba' => '$category expression',
'kind' => 'token',
'min' => 12347,
'pkg' => undef,
're' => bless({
'decl' => [],
'a' => 0,
'dba' => '$category expression',
'i' => 0,
'min' => 12347,
'r' => 1,
's' => 0,
'zyg' => [
bless({
'a' => 0,
'dba' => '$category expression',
'i' => 0,
'min' => 1,
share/P6STD/CursorBase.pmc view on Meta::CPAN
}, 'RE_string'),
bless({
'a' => 0,
'dba' => '$category expression',
'i' => 0,
'min' => 12345,
'name' => 'semilist',
'r' => 1,
'rest' => '',
's' => 0,
}, 'RE_method'),
bless({
'decl' => [],
'min' => 1,
're' => bless({
'a' => 0,
'dba' => '$category expression',
'i' => 0,
'min' => 1,
'r' => 1,
's' => 0,
'zyg' => [
bless({
'a' => 0,
'dba' => '$category expression',
'i' => 0,
'min' => 1,
'r' => 1,
's' => 0,
'text' => $stopper,
}, 'RE_string'),
bless({
'min' => 0,
'name' => 'FAILGOAL',
'nobind' => 1,
}, 'RE_method'),
],
}, 'RE_first'),
}, 'RE_bracket'),
bless({
'min' => 0,
'name' => 'O',
'rest' => '(|%term)',
}, 'RE_method'),
],
}, 'RE_sequence'),
}, 'RE_ast'),
};
our \$CATEGORY = '$category';
sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
sub $mangle {
no warnings 'recursion';
my \$self = shift;
local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
my %args = \@_;
local \$::sym = \$args{sym} // $sym;
return () if \$::GOAL eq $starter;
my \$C = \$self->cursor_xact("RULE $mangle");
my \$xact = \$C->xact;
my \$S = \$C->{'_pos'};
\$C->{'sym'} = ref \$sym ? join(' ', \@\$sym) : \$sym;
\$self->_MATCHIFYr(\$S, "$mangle",
do {
if (my (\$C) = (\$C->_EXACT($starter))) {
do {
if (my (\$C) = (((local \$::GOAL = $stopper , my \$goalpos = \$C), \$C->unbalanced($stopper))[-1])) {
do {
if (my (\$C) = (\$C->_SUBSUMEr(['semilist'], sub {
my \$C = shift;
\$C->semilist
}))) {
do {
if (my (\$C) = (\$C->_BRACKETr(sub {
my \$C=shift;
do {
my \$C = \$C->cursor_xact('ALT ||');
my \$xact = \$C->xact;
my \@gather;
do {
push \@gather, \$C->_EXACT($stopper)
}
or \$xact->[-2] or
do {
push \@gather, \$C->FAILGOAL($stopper , '$category expression',\$goalpos)};
\@gather;
}
}))) {
\$C->_SUBSUMEr(['O'], sub {
my \$C = shift;
\$C->O(%STD::$coercion)
});
}
else {
();
}
};
}
else {
();
}
};
}
else {
();
}
};
}
else {
();
}
}
);
}
1;
END
}
$lang->deb("derive $genpkg from $WHAT adding $mangle") if DEBUG & DEBUG::mixins;
eval $e or die "Cannot create $name: $@\n";
$::LANG{'MAIN'} = $lang->cursor_fresh($genpkg);
}
$lang;
}
sub add_enum { my $self = shift;
my $type = shift;
my $expr = shift;
return unless $type;
return unless $expr;
my $typename = $type->Str;
local $::IN_DECL = 'constant';
# XXX complete kludge, really need to eval EXPR
$expr =~ s/:(\w+)<\S+>/$1/g; # handle :name<string>
for ($expr =~ m/([a-zA-Z_]\w*)/g) {
$self->add_name($typename . "::$_");
$self->add_name($_);
}
$self;
}
sub do_use { my $self = shift;
my $module = shift;
my $args = shift;
my @imports;
$self->do_need($module);
$self->do_import($module,$args);
$self;
}
sub do_need { my $self = shift;
my $m = shift;
my $module = $m->Str;
my $topsym = $self->sys_load_modinfo($module);
$self->add_my_name($module);
$::DECLARAND->{really} = $topsym;
$self;
}
sub do_import { my $self = shift;
my $m = shift;
my $args = shift;
my @imports;
my $module = $m->Str;
if ($module =~ /(class|module|role|package)\s+(\S+)/) {
$module = $2;
}
my $pkg = $self->find_stash($module);
if ($pkg->{really}) {
$pkg = $pkg->{really}->{UNIT};
}
else {
$pkg = $self->find_stash($module . '::');
}
if ($args) {
my $text = $args->Str;
return $self unless $text;
while ($text =~ s/^\s*:?(OUR|MY|STATE|HAS|AUGMENT|SUPERSEDE)?<(.*?)>,?//) {
my $scope = lc($1 // 'my');
( run in 1.387 second using v1.01-cache-2.11-cpan-39bf76dae61 )