Benchmark-Perl-Formance-Cargo
view release on metacpan or search on metacpan
share/P6STD/viv view on Meta::CPAN
{ package VAST::regex_declarator__S_regex; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
local $::RATCHET = 0;
local $::SIGSPACE = 0;
local $::REGEX_DECLARATOR = 'regex';
my $comment = substr($ORIG, $self->{BEG},100);
$comment =~ s/\n.*//s;
"## $comment\n" . $self->{regex_def}->p5;
}
}
{ package VAST::regex_declarator__S_rule; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
local $::RATCHET = 1;
local $::SIGSPACE = 1;
local $::REGEX_DECLARATOR = 'rule';
my $comment = substr($ORIG, $self->{BEG},100);
$comment =~ s/\n.*//s;
"## $comment\n" . $self->{regex_def}->p5;
}
}
{ package VAST::regex_declarator__S_token; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
local $::RATCHET = 1;
local $::SIGSPACE = 0;
local $::REGEX_DECLARATOR = 'token';
my $comment = substr($ORIG, $self->{BEG}, 100);
$comment =~ s/\n.*//s;
"## $comment\n" . $self->{regex_def}->p5;
}
}
{ package VAST::regex_def; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
RE_ast->new(kind => $::REGEX_DECLARATOR, decl => \@::DECLAST,
re => $self->{regex_block}{nibble}{"."}->re_ast);
}
sub protoregex { my $self = shift; my $name = shift;
$::RETREE->{$name . ":*"} = { dic => $::PKG };
for my $t ($self->kids("trait")) {
if ($t->{trait_mod}{longname} &&
$t->{trait_mod}{longname}->Str eq 'endsym') {
$::PROTOENDSYM->{$name} =
$t->{trait_mod}{circumfix}[0]{nibble}->Str;
}
}
$::PROTOSIG->{$name} = ($self->kids("signature"))[0];
<<EOT;
sub ${name}__PEEK { \$_[0]->_AUTOLEXpeek('$name:*',\$retree); }
sub $name {
my \$self = shift;
my \$subs;
local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
my \$C = \$self->cursor_xact('RULE $name');
my \$S = \$C->{'_pos'};
my \@result = do {
my (\$tag, \$try);
my \@try;
my \$relex;
my \$x;
if (my \$fate = \$C->{'_fate'}) {
if (\$fate->[1] eq '$name') {
\$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
(\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
\@try = (\$try);
\$x = 'ALT $name';
}
else {
\$x = 'ALTLTM $name';
}
}
else {
\$x = 'ALTLTM $name';
}
my \$C = \$C->cursor_xact(\$x);
my \$xact = \$C->{_xact};
my \@gather = ();
for (;;) {
unless (\@try) {
\$relex //= \$C->cursor_fate('$::PKG', '$name:*', \$retree);
\@try = \$relex->(\$C) or last;
}
\$try = shift(\@try) // next;
if (ref \$try) {
(\$C->{'_fate'}, \$tag, \$try) = \@\$try; # next candidate fate
}
\$C->deb("$name trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
push \@gather, \$C->\$try(\@_);
last if \@gather;
last if \$xact->[-2]; # committed?
}
\$self->_MATCHIFYr(\$S, "$name", \@gather);
};
\@result;
}
EOT
}
sub emit_p5 { my $self = shift;
my $name = $self->{deflongname}[0]{name}->Str;
$::OVERRIDERX{$name} = 1;
if (defined $::MULTINESS && $::MULTINESS eq 'proto') {
return $self->protoregex($name);
}
my $p5name = $name;
my %adv = $self->{deflongname}[0]->adverbs;
local $::SYM = $adv{sym};
local $::ENDSYM = $::PROTOENDSYM->{$name};
local $::REV = '';
local $::PLURALITY = 1;
local @::DECL;
local @::DECLAST;
local $::NEEDORIGARGS = 0;
local $::IGNORECASE = 0;
local $::PAREN = 0;
local %::BINDINGS;
my $spcsig = $self->kids('signature') ?
(($self->kids('signature'))[0])->p5 : '';
my $defsig = $::PROTOSIG->{$name} ? $::PROTOSIG->{$name}->p5 : '';
if (defined $adv{sym}) {
$p5name = sprintf "%s__S_%03d%s", $name, $::MULTIRX_SEQUENCE++,
::mangle(split " ", $adv{sym});
push @{$::PROTORX_HERE{$name}}, $p5name . "__PEEK";
}
local $::DBA = $name;
local $::DECL_CLASS = $::PKG;
local $::NAME = $p5name;
local $::ALT = 0;
my $ast = $self->re_ast->optimize;
$::RETREE->{$p5name} = $ast;
my $urbody = $ast->walk;
say STDERR "<<< " . $urbody . ": " . $urbody->p5expr if $OPT_log;
my ($body, $ratchet) = $urbody->uncut;
say STDERR "<<< " . $body . ": " . $body->p5expr if $OPT_log;
$ast->{dba_needed} = 1;
$ast->clean;
<<HDR
sub ${p5name}__PEEK { \$_[0]->_AUTOLEXpeek('$p5name', \$retree) }
sub $p5name {
HDR
. ::indent(<<IHDR
no warnings 'recursion';
my \$self = shift;
IHDR
. ($::NEEDORIGARGS ? " my \@origargs = \@_;\n" : "")
. ::indent($defsig || $spcsig, 1)
. ::indent(join("", @::DECL), 1)
. <<TEXT
local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
my \$C = \$self->cursor_xact("RULE $p5name");
my \$xact = \$C->xact;
my \$S = \$C->{'_pos'};
TEXT
. join("", map { "\$C->{'$_'} = [];\n" }
grep { $::BINDINGS{$_} > 1 }
sort keys %::BINDINGS)
. ($::SYM ? '$C->{sym} = "' . ::rd($::SYM) . "\";\n" : '')
. <<END
\$self->_MATCHIFY$ratchet(\$S, "$p5name", ${\ $body->p5expr });
END
, 1) . "}\n";
}
}
{ package VAST::Replication; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::right; our @ISA = 'VAST::Base';
}
{ package VAST::routine_declarator; our @ISA = 'VAST::Base';
}
{ package VAST::routine_declarator__S_method; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $comment = substr($ORIG, $self->{BEG},100);
$comment =~ s/\s*\{.*//s;
"## $comment\n" . $self->{method_def}->p5;
}
}
{ package VAST::regex_infix; our @ISA = 'VAST::Base';
}
{ package VAST::regex_infix__S_Tilde; our @ISA = 'VAST::Base';
}
{ package VAST::regex_infix__S_Vert; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $altname = $::NAME . "_" . $::ALT++;
RE_any->new(altname => $altname,
zyg => [map { $_->re_ast } $self->kids('args')]);
}
}
{ package VAST::regex_infix__S_VertVert; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
RE_first->new(map { $_->re_ast } $self->kids('args'));
}
}
share/P6STD/viv view on Meta::CPAN
my $l = $$kid->has_trailing_ws(1);
$$kid->remove_leading_ws;
last unless $l;
}
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
for my $kid ($self->kids) {
$before = $$kid->has_trailing_ws($before);
}
$before;
}
}
{ package RE_any; use base "REbase";
sub _walk {
my $self = shift;
my @result;
my $alt = 0;
my $altname = $self->{altname};
if ($$self{zyg}) {
my %B = %::BINDINGS;
for my $kid (@{$$self{zyg}}) {
local %::BINDINGS;
my $r = $kid->walk;
for my $b (keys %::BINDINGS) {
$B{$b} = 2 if $::BINDINGS{$b} > 1 or $B{$b};
}
push @result, $r;
$kid->{alt} = $altname . ' ' . $alt++;
}
%::BINDINGS = %B;
}
if (@result == 1) {
$result[0];
}
else {
$::RETREE->{$self->{altname}} = $self;
$self->{dba_needed} = 1;
my $result = <<"END";
do {
my (\$tag, \$try);
my \@try;
my \$relex;
my \$fate;
my \$x;
if (\$fate = \$C->{'_fate'} and \$fate->[1] eq '$altname') {
\$C->deb("Fate passed to $altname: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
(\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
\@try = (\$try);
\$x = 'ALT $altname'; # some outer ltm is controlling us
}
else {
\$x = 'ALTLTM $altname'; # we are top level ltm
}
my \$C = \$C->cursor_xact(\$x);
my \$xact = \$C->{_xact};
my \@gather = ();
for (;;) {
unless (\@try) {
\$relex //= \$C->cursor_fate('$::PKG', '$altname', \$retree);
\@try = \$relex->(\$C) or last;
}
\$try = shift(\@try) // next;
if (ref \$try) {
(\$C->{'_fate'}, \$tag, \$try) = \@\$try; # next candidate fate
}
\$C->deb("$altname trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
push \@gather, ((
END
for my $i (0 .. @result - 1) {
$result .= ::indent(DEEP::chunk($result[$i])->p5expr, 3);
if ($i != @result - 1) {
$result .= ",";
}
$result .= "\n";
}
$result .= <<END;
)[\$try])->(\$C);
last if \@gather;
last if \$xact->[-2]; # committed?
}
\@gather;
};
END
DEEP::raw($result, isblock => 1);
}
}
sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
sub optimize { my $self = shift()->SUPER::optimize;
my @ok;
for my $k (@{$self->{zyg}}) {
if ($k->isa('RE_any')) {
push @ok, @{$k->{zyg}};
} else {
push @ok, $k;
}
}
return $ok[0] if @ok == 1;
$self->{zyg} = \@ok;
$self;
}
# yes, this affects LTM, but S05 specs it
sub remove_leading_ws {
my $self = shift;
for my $kid (@{$$self{zyg}}) {
$kid->remove_leading_ws();
}
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
my $after = 1;
for my $kid ($self->kids) {
$after &&= $$kid->has_trailing_ws($before);
}
$after;
}
}
{ package RE_first; use base "REbase";
sub new {
my ($class, @zyg) = @_;
$class->SUPER::new(zyg => \@zyg);
}
sub _walk {
my $self = shift;
my @result;
if ($$self{zyg}) {
my %B = %::BINDINGS;
foreach my $kid (@{$$self{zyg}}) {
local %::BINDINGS;
push @result, $kid->walk->p5expr;
for my $b (keys %::BINDINGS) {
$B{$b} = 2 if $::BINDINGS{$b} > 1 or $B{$b};
}
}
%::BINDINGS = %B;
}
if (@result == 1) {
DEEP::raw($result[0]);
}
else {
die("Cannot reverse serial disjunction") if $::REV;
for (@result) { $_ = "do {\n" . ::indent("push \@gather, $_\n") . "}"; }
# We need to force the scope here because of the my $C
my $result = "do {" . ::indent(
"my \$C = \$C->cursor_xact('ALT ||');\n" .
"my \$xact = \$C->xact;\nmy \@gather;\n" .
join("\nor \$xact->[-2] or\n", @result) . ";\n" .
"\@gather;\n") . "}";
DEEP::raw($result);
}
}
sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
sub remove_leading_ws {
my $self = shift;
for my $kid (@{$$self{zyg}}) {
$kid->remove_leading_ws();
}
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
my $after = 1;
for my $kid ($self->kids) {
$after &&= $$kid->has_trailing_ws($before);
}
$after;
}
}
{ package RE_method; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{nobind};
delete $self->{need_match};
$self->{rest} = defined $self->{rest};
}
sub _walk {
my $self = shift;
local $::NEEDMATCH = 0;
my $name = $$self{name};
die "Cannot reverse $name" if $::REV;
my $re;
if ($name eq "sym") {
$$self{i_needed} = 1;
$$self{sym} = $::SYM;
$$self{endsym} = $::ENDSYM if defined $::ENDSYM;
if ($$self{i}) {
return DEEP::p5regex("(?i:" . ::rd($::SYM) . ")");
}
else {
return DEEP::p5regex(::rd($::SYM), has_meta => 0);
}
}
elsif ($name eq "alpha") {
return DEEP::p5regex("[_[:alpha:]]");
}
elsif ($name eq "_ALNUM") {
return DEEP::p5regex("\\w");
}
elsif ($name eq "nextsame") {
$::NEEDORIGARGS++;
$re = '$self->SUPER::' . $::NAME . '(@origargs)';
}
elsif ($name =~ /^\w/) {
my $al = $self->{rest} // '';
$re = '$C->' . $name . $al;
}
else {
my $al = $self->{rest} // '';
$re = <<"END";
do {
if (not $name) {
\$C;
}
elsif (ref $name eq 'Regexp') {
if (\$::ORIG =~ m/$name/gc) {
\$C->cursor(\$+[0]);
}
else {
();
}
}
else {
\$C->$name$al;
}
}
END
}
$re = "do {\n" . ::indent("my \$M = \$C;\n$re") . "\n}" if $self->{need_match};
$re = DEEP::raw($re);
if ($name =~ /^\w/ and not $self->{nobind}) {
$::BINDINGS{$name} += $::PLURALITY;
$re = $self->bind($re, $name);
}
$re;
}
sub has_trailing_ws {
my $self = shift;
return $self->{name} eq 'ws';
}
sub remove_leading_ws {
my $self = shift;
if ($self->{name} eq 'ws' && $self->{nobind}) {
bless $self, 'RE_noop';
}
}
}
{ package RE_ast; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{decl};
delete $self->{kind};
}
sub _walk {
my $self = shift;
if ($$self{decl}) {
for my $decl (@{$$self{decl}}) {
push @::DECL, $decl->walk->p5block;
}
}
if ($$self{re}) {
$$self{re}->walk;
}
}
sub kids { my $self = shift; \$self->{re}, map { \$_ } @{$self->{decl}}; }
}
{ package RE_quantified_atom; use base "REbase";
# handles cutting itself
sub clean { my $self = shift;
$self->SUPER::clean;
splice @{$self->{quant}}, ($self->{quant}[0] eq '**' ? 3 : 1);
}
share/P6STD/viv view on Meta::CPAN
$re = DEEP::raw('$C->' . $name . "(" . ::hang(DEEP::chunk(DEEP::raw($re, isblock => 1))->p5expr, " ") . ")");
if ($name =~ /^\w/ and not $self->{nobind}) {
$re = $self->bind($re, $name);
$::BINDINGS{$name} += $::PLURALITY;
}
$re;
}
sub kids { my $self = shift; \$self->{re} }
}
{ package RE_assertion; use base "REbase";
sub _walk {
my $self = shift;
if ($$self{assert} eq '!') {
my $re = $$self{re}->walk;
DEEP::raw("\$C->_NOTBEFORE(" . ::hang(DEEP::chunk($re)->p5expr, " ") .")");
}
else {
my $re = $$self{re}->walk;
return $re if $re->p5expr =~ /^\$C->before/; #XXX
DEEP::raw("\$C->before(" . ::hang(DEEP::chunk($re)->p5expr, " ") . ")");
}
}
# TODO: Investigate what the LTM engine is doing with assertions and
# optimize harder.
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$before; # Transparent
}
sub remove_leading_ws {
my $self = shift;
$self->{re}->remove_leading_ws;
}
sub kids { my $self = shift; \$self->{re} }
}
{ package RE_meta; use base "REbase";
sub _walk {
my $self = shift;
my $text = $$self{text};
my $not = 0;
my $code = "";
my $bt = 0;
if ($text =~ /^(\\[A-Z])(.*)/) {
$text = lc($1) . $2;
$not = 1;
}
# to return yourself, you must either be a symbol or handle $not
if ($text eq '.') {
if ($::REV) {
return DEEP::p5regex("(?<=(?s:.)");
}
else {
$code = "\$C->cursor_incr()";
}
}
elsif ($text eq '.*') {
$code = "\$C->_SCANg$::REV()";
$bt = 1;
}
elsif ($text eq '.*?') {
$code = "\$C->_SCANf$::REV()";
$bt = 1;
}
elsif ($text eq '^') {
return DEEP::p5regex('\A');
}
elsif ($text eq '^^') {
return DEEP::p5regex('(?m:^)');
}
elsif ($text eq '$') {
return DEEP::p5regex('\z');
}
elsif ($text eq '$$') {
return DEEP::p5regex('(?m:$)');
}
elsif ($text eq ':') {
my $extra = $self->{extra} || '';
$code = "(($extra), \$C)[-1]";
}
elsif ($text eq '::') {
$code = "\$C->_COMMITLTM$::REV()";
}
elsif ($text eq '::>') {
$code = "\$C->_COMMITBRANCH$::REV()";
}
elsif ($text eq ':::') {
$code = "\$C->_COMMITRULE$::REV()";
}
elsif ($text eq '\\d') {
if ($::REV) {
return DEEP::p5regex($not ? '(?<=\D)' : '(?<=\d)');
}
else {
return DEEP::p5regex($not ? '\D' : '\d');
}
}
elsif ($text eq '\\w') {
if ($::REV) {
return DEEP::p5regex($not ? '(?<=\W)' : '(?<=\w)');
}
else {
return DEEP::p5regex($not ? '\W' : '\w');
}
}
elsif ($text eq '\\s') {
if ($::REV) {
return DEEP::p5regex($not ? '(?<=\W)' : '(?<=\w)');
}
else {
return DEEP::p5regex($not ? '\S' : '\s');
}
}
elsif ($text eq '\\h') {
( run in 1.022 second using v1.01-cache-2.11-cpan-39bf76dae61 )