#!/usr/bin/env perl
=head1 NAME
viv - A retargettable Perl 6 metacompiler
=head1 DESCRIPTION
C<viv> converts code, written in a subset of Perl 6, into code in Perl 5 (and
eventually several other languages). C<viv> is B<not a general compiler>; it
makes little to no attempt to provide faithful Perl 6 semantics, so code
intended to be run through viv needs to restrict itself to a "nice" subset of
Perl 6. Exactly what "nice" means hasn't been completely nailed down, but
multithreading, the MOP, augmenting system classes, and operator overloading
are all almost certainly out.
* First, viv reads your source code (which must be encoded in UTF-8). If the
--thaw option is provided, the source is expected to be in Storable format;
this eliminates parsing overhead and makes viv ~7 times faster. Useful for
experimenting with modifications to viv itself.
* Second, the source code is parsed into an object-oriented abstract syntax
tree using STD.pm6 and STD::Actions. If --freeze is passed, the process stops
here and a Storable dump is generated.
* Translation of the parse tree into output code occurs in a single interleaved
pass, however it takes different paths for regex and non-regex code.
Non-regex code is mostly passed through, with targetted syntax-dependant
rewrites; as possible, we are changing this to generate DEEP. Regexes are
converted into a narrowed REgex AST format, which is translated into DEEP and
additionally dumped for post-translation processing by the LTM engine.
* The DEEP engine handles differences between output formats, taking advantage
of its much narrower form.
=cut
use FindBin;
BEGIN { unshift @INC, $FindBin::Bin if -s "$FindBin::Bin/STD.pmc"; }
use strict;
use 5.010;
use warnings FATAL => 'all';
use List::Util qw/sum min/;
use STD;
use utf8;
use YAML::XS; # An attempt to replace this with YAML::Syck passed the
# tests but produced a different output format that
# confused some calling programs. For example, anchors
# are usually numbers ascending from 1, and they became
# disjoint sets of descending numbers. Also, empty
# sequences shown as [] became followed by an empty line.
# See also: YAML::Syck in package VAST::package_def below.
use Encode;
use Scalar::Util 'blessed', 'refaddr';
use Storable;
use Try::Tiny;
our $OPT_match = 0;
our $OPT_log = 0;
our $OPT_stab = 0;
our $OPT_thaw = 0;
our $OPT_keep_going = 0;
our $OPT_output_file = undef;
my $PROG = '';
our $ORIG;
my $U = 0;
my @did_ws;
BEGIN {
# Let's say you have a tricky optimization that breaks the build. You want
# to know exactly which rewrite is culpable? Try bisecting with
# VIV_OPTLIMIT, after wrapping the rewrite in if (DARE_TO_OPTIMIZE).
my $optlimit = $ENV{VIV_OPTLIMIT};
if (defined $optlimit) {
*DARE_TO_OPTIMIZE = Sub::Name::subname(DARE_TO_OPTIMIZE => sub {
$optlimit-- > 0
});
} else {
constant->import(DARE_TO_OPTIMIZE => 1);
}
};
my @context;
$::MULTINESS = '';
# XXX STD Global trait tables simulate inheritence
local $::PROTO = {};
local $::PROTOSIG = {};
sub USAGE {
print <<'END';
viv [switches] filename
where switches can be:
-e use following argument as program
-o send output to following argument instead of STDOUT
--yaml spit out a parsable abstract syntax tree
--concise spit out a short syntaxe tree (default)
--p5 spit out a Perl 5 representation
--p6 spit out a Perl 6 representation
--psq spit out a Perlesque representation (very incomplete)
--no-indent disable output indentation for faster parsing
--freeze generate a Storable representation
--thaw use existing Storable of AST from filename
--stab include the symbol table
--pos include position info in AST
--match include match tree info in AST
--log emit debugging info to standard error
--keep-going continue after output errors
END
exit;
}
use STD::Actions;
sub spew {
my $bits = shift;
$bits .= "\n" unless $bits ~~ /\n\z/;
if (defined $OPT_output_file) {
open my $out, ">", $OPT_output_file
or die "cannot open $OPT_output_file for writing: $!";
binmode $out, ":utf8";
print $out $bits or die "cannot write: $!";
close $out or die "cannot close: $!";
} else {
print $bits;
}
}
sub MAIN {
my $output = 'concise';
USAGE() unless @_;
while (@_) {
last unless $_[0] =~ /^-/;
my $switch = shift @_;
if ($switch eq '--eval' or $switch eq '-e') {
$PROG .= Encode::decode_utf8(shift(@_)) . "\n";
}
elsif ($switch eq '--output' or $switch eq '-o') {
$OPT_output_file = shift(@_);
}
elsif ($switch eq '--yaml' or $switch eq '-y') {
$output = 'yaml';
}
elsif ($switch eq '--concise' or $switch eq '-c') {
$output = 'concise';
}
elsif ($switch eq '--p5' or $switch eq '-5') {
$output = 'p5';
}
elsif ($switch eq '--p6' or $switch eq '-6') {
$output = 'p6';
}
elsif ($switch eq '--psq') {
$output = 'psq';
}
elsif ($switch eq '--freeze') {
$output = 'store';
}
elsif ($switch eq '--stab' or $switch eq '-s') {
$OPT_stab = 1;
}
elsif ($switch eq '--log' or $switch eq '-l') {
$OPT_log = 1;
}
elsif ($switch eq '--pos' or $switch eq '-p') {
# obsolete, ignored
}
elsif ($switch eq '--no-indent') {
no warnings 'redefine';
*indent = \&no_indent;
*hang = \&no_indent;
}
elsif ($switch eq '--match' or $switch eq '-m') {
$OPT_match = 1; # attach match object
}
elsif ($switch eq '--thaw') {
$OPT_thaw = 1;
}
elsif ($switch eq '--keep-going' or $switch eq '-k') {
$OPT_keep_going = 1;
}
elsif ($switch eq '--help') {
USAGE();
}
}
# USAGE() unless -r $_[0];
my $r;
if ($OPT_thaw) {
my $raw = retrieve($_[0]);
$ORIG = $raw->{ORIG};
$r = $raw->{AST};
$STD::ALL = $raw->{STABS};
for my $cl (keys %{$raw->{GENCLASS}}) {
STD::Actions::gen_class($cl, $raw->{GENCLASS}->{$cl});
}
}
elsif (@_ and -f $_[0]) {
$r = STD->parsefile($_[0], text_return => \$ORIG,
actions => 'STD::Actions')->{'_ast'};
}
else {
if (not $PROG) {
local $/;
@ARGV = @_;
$PROG = <>;
}
$ORIG = $PROG;
$r = STD->parse($PROG, actions => 'STD::Actions')->{'_ast'};
}
unless ($OPT_thaw) {
$ORIG =~ s/\n;\z//;
}
if ($OPT_stab) {
no warnings;
$r->{stabs} = $STD::ALL;
}
if ($output eq 'yaml') {
my $x = Dump($r);
# $x =~ s/\n.*: \[\]$//mg;
spew $x;
}
elsif ($output eq 'concise') {
spew concise($r, 80);
}
elsif ($output eq 'p6') {
spew $r->p6;
}
elsif ($output eq 'psq') {
spew $r->psq;
}
elsif ($output eq 'p5') {
spew fixpod($r->p5);
}
elsif ($output eq 'store') {
delete $r->{stabs};
my $data = { AST => $r, GENCLASS => \%STD::Actions::GENCLASS,
ORIG => $ORIG, STABS => $STD::ALL };
defined($OPT_output_file) ? store($data, $OPT_output_file)
: Storable::store_fd($data, \*STDOUT);
}
else {
die "Unknown output mode";
}
}
sub no_indent { $_[0] }
sub hang {
my ($arg, $leader) = @_;
$arg =~ s/\n/\n$leader/g;
return $arg;
}
sub listify {
my $r = "";
for my $i (0 .. $#_) {
$r .= ($i == $#_) ? "\n└─" : "\n├─";
$r .= hang($_[$i], $i == $#_ ? " " : "│ ");
}
$r;
}
sub shred {
my ($first, $rest, $tx) = @_;
my $out = "";
while (length $tx > $first) {
$out .= substr($tx, 0, $first);
$out .= "\n";
$tx = substr($tx, $first);
$first = $rest;
}
$out . $tx;
}
sub concise {
my ($node, $width) = @_;
$width = 30 if $width < 30;
if (!ref $node) {
return defined($node) ? shred($width, $width, "$node") : "undef";
} elsif (blessed($node) && ref($node) =~ /^VAST/) {
my @pos =
ref($node->{"."}) eq 'ARRAY' ? @{$node->{"."}} :
defined($node->{"."}) ? $node->{"."} :
();
my %nam = %$node;
delete $nam{"."};
# don't list the same node twice
my %inpos = map { ref($_) ? (refaddr($_) , 1) : () } @pos;
@pos = map { concise($_, $width-2) } @pos;
my @oobnam;
my $title = blessed $node;
my $x = length($title);
for my $ch (sort keys %nam) {
next if $ch eq '_fate';
if (ref $nam{$ch}) {
# hide named children that are just (lists of) positional children
if ($inpos{refaddr($nam{$ch})}) { next }
if (ref($nam{$ch}) eq 'ARRAY') {
my $all = 1;
for (@{$nam{$ch}}) { $all = 0 unless ref $_ && $inpos{refaddr $_} }
next if $all;
}
}
my $repr = concise($nam{$ch}, $width-4);
if ($repr !~ /\n/ && length $repr < 30) {
if ($x + length($ch) + length($repr) + 6 > $width) {
$title .= ",\n";
$x = 4;
} else {
$title .= ", ";
$x += 2;
}
$title .= "$ch: $repr";
$x += length("$ch: $repr");
} else {
my $hang = " " x (length($ch)+2);
push @oobnam, "$ch: " . hang($repr, $hang);
}
}
$title = hang($title, (@pos ? "│ " : " ") . (@oobnam ? "│ " : " "));
my $result = $title;
$result .= hang(listify(@oobnam), @pos ? "│ " : " ");
$result .= listify(@pos);
return $result;
} else {
my $d = Dump($node);
return substr($d, 4, length($d)-5);
}
}
# viv should likely be abstracted into a module instead of doing this hack... - pmurias
sub VIV::SET_OPT {
my %opt = @_;
$OPT_match = $opt{match};
$OPT_log = $opt{log};
}
sub fixpod {
my $text = shift;
return $text unless $text =~ /\n/;
my @text = split(/^/, $text);
my $in_begin = 0;
my $in_for = 0;
for (@text) {
$in_begin = $1 if /^=begin\s+(\w+)/;
$in_for = 1 if /^=for/;
$in_for = 0 if /^\s*$/;
my $docomment = $in_begin || $in_for;
$in_begin = 0 if /^=end\s+(\w+)/ and $1 eq $in_begin;
s/^/# / if $docomment;
}
join('', @text);
}
# rules of thumb: a block (0 or more statements) is a chunk of text, use
# indent. for expressions, the overall philosophy is that the indentation
# of a line should be proportional to the number of outstanding syntactic
# groups
sub indent {
my $x = shift || '';
my $i = shift || 1;
my $s = ' ' x $i;
$x =~ s/^/$s/mg;
$x;
}
sub unsingle {
my $in = $_[0];
my $out = '';
while ($in ne '') {
$out .= $1 if $in =~ s/^\\([\\'])//;
$out .= $1 if $in =~ s/^(.)//;
}
$out;
}
# XXX this is only used for backslash escapes in regexes
sub undouble {
my $in = $_[0];
my $out = '';
my %trans = ( 'n' => "\n" );
while ($in ne '') {
$out .= $trans{$1} // $1 if $in =~ s/^\\(.)//;
$out .= $1 if $in =~ s/^(.)//;
}
$out;
}
sub rd {
my $in = shift;
my $out = '';
for my $ch (split //, $in) {
$out .= $ch eq "\n" ? '\n' : quotemeta($ch);
}
$out;
}
###################################################################
{ package VAST::Base;
sub Str { my $self = shift;
my $b = $self->{BEG};
my $e = $self->{END};
return '' if $b > length($ORIG);
substr($ORIG, $b, $e - $b);
}
sub kids { my $self = shift;
my $key = shift() // '.';
return () unless exists $self->{$key};
my $entry = $self->{$key};
return ref($entry) eq 'ARRAY' ? @$entry : $entry;
}
sub emit_p6 { my $self = shift;
my @text;
if (exists $self->{'.'}) {
my $last = $self->{BEG};
my $all = $self->{'.'};
my @kids;
for my $kid (ref($all) eq 'ARRAY' ? @$all : $all) {
next unless $kid;
if (not defined $kid->{BEG}) {
$kid->{BEG} = $kid->{_from} // next;
$kid->{END} = $kid->{_pos};
}
push @kids, $kid;
}
for my $kid (sort { $a->{BEG} <=> $b->{BEG} } @kids) {
my $kb = $kid->{BEG};
if ($kb > $last) {
push @text, substr($ORIG, $last, $kb - $last);
}
if (ref($kid) eq 'HASH') {
print STDERR ::Dump($self);
die "in a weird place";
}
push @text, scalar $kid->p6;
$last = $kid->{END};
}
my $se = $self->{END};
if ($se > $last) {
push @text, substr($ORIG, $last, $se - $last);
}
}
else {
# print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
push @text, $self->{TEXT};
}
wantarray ? @text : join('', @text);
}
sub emit_p5 { my $self = shift;
my @text;
if (exists $self->{'.'}) {
my $last = $self->{BEG};
my $all = $self->{'.'};
my @kids;
for my $kid (ref($all) eq 'ARRAY' ? @$all : $all) {
next unless $kid;
if (not defined $kid->{BEG}) {
$kid->{BEG} = $kid->{_from} // next;
$kid->{END} = $kid->{_pos};
}
push @kids, $kid;
}
for my $kid (sort { $a->{BEG} <=> $b->{BEG} } @kids) {
my $kb = $kid->{BEG};
if ($kb > $last) {
push @text, substr($ORIG, $last, $kb - $last);
}
if (ref($kid) eq 'HASH') {
print STDERR ::Dump($self);
die "in a weird place";
}
push @text, scalar $kid->p5;
$last = $kid->{END};
}
my $se = $self->{END};
if ($se > $last) {
push @text, substr($ORIG, $last, $se - $last);
}
}
else {
# print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
push @text, $self->{TEXT};
}
wantarray ? @text : join('', @text);
}
BEGIN {
my $tpl = <<'TEMPLATE';
sub VAST::Base::FORM { my $self = shift; my $lvl = @context;
my @text;
say STDERR ' ' x $lvl, ref $self, " from ",$self->{BEG}," to ",$self->{END} if $OPT_log;
$context[$lvl] = $self;
# print STDERR "HERE " . ref($self) . "\n";
local $SIG{__DIE__} = sub {
my @args = @_;
$args[-1] =~ s/ at .*? line .*?\n$//s if $args[-1] =~ /\n$/s;
die Carp::longmess(@args);
};
my @bits = !$OPT_keep_going ? $self->emit_FORM(@_) : (::try {
$self->emit_FORM(@_);
} ::catch {
my $char = $self->{BEG} // $self->{_from} // 0;
my $line = 1 + (substr($ORIG, 0, $char) =~ y/\n/\n/);
say STDERR "!!! FAILED at $char (L$line)";
print STDERR $_;
"<<< ERROR >>>";
});
my $val = join '', @bits;
my @c = map { ref $_ } @context;
my $c = "@c";
$c =~ s/VAST:://g;
say STDERR ' ' x ($lvl-1), "$c returns $val\n" if $OPT_log;
# Note that we may have skipped levels, so you can't just pop
splice(@context,$lvl);
wantarray ? @bits : $val;
}
TEMPLATE
for my $format (qw/p5 p6 psq/) {
my $t = $tpl;
$t =~ s/FORM/$format/g;
eval $t;
}
}
sub gap { my $self = shift;
my $after = shift;
my $beg = $self->{END};
my $end = $after->{BEG};
return '' unless $beg && $end;
return substr($ORIG, $beg, $end - $beg);
}
sub base_re_quantifier { my $self = shift; my $x = shift; my $min = shift;
my $qm = $self->{quantmod}->Str;
$qm =~ s/:(.)/$1/;
$qm ||= $::RATCHET ? ':' : '!';
$qm =~ s/\+/!/;
return [ $self->{SYM}, $qm, $x, $min ];
}
}
{ package VAST::ViaDEEP;
sub emit_psq { my $self = shift;
$self->_deep->psqexpr;
}
}
{ package VAST::InfixCall;
sub emit_psq { my $self = shift;
return DEEP::call("infix:<" . $self->{infix}{SYM} . ">",
map { DEEP::raw($_->psq) } $self->kids('args'))->psqexpr;
}
}
{ package VAST::Str; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
return $self->{TEXT};
}
sub emit_p6 { my $self = shift;
return $self->{TEXT};
}
}
{ package VAST::Additive; our @ISA = ('VAST::Base', 'VAST::InfixCall');
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if ($t[0] eq '*') { # *-1
$t[0] = '';
}
@t;
}
}
{ package VAST::Adverb; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
my $adv = pop @t;
if ($adv eq ':delete' or $adv eq ':exists') {
$adv =~ s/^://;
unshift(@t, $adv . ' ');
$t[-1] =~ s/\s+$//;
}
@t;
}
}
{ package VAST::apostrophe; our @ISA = 'VAST::Base';
}
{ package VAST::arglist; our @ISA = 'VAST::Base';
}
{ package VAST::args; our @ISA = 'VAST::Base';
sub deepn { my $self = shift;
my $al = $self->{arglist}[0] // $self->{semiarglist}{arglist}[0];
return unless $al;
$al = $al->{EXPR} or return;
if ($al->isa('VAST::infix__S_Comma')) {
return map { DEEP::raw($_->psq) } $al->kids('args');
} else {
return DEEP::raw($al->psq);
}
}
}
{ package VAST::assertion; our @ISA = 'VAST::Base';
}
{ package VAST::assertion__S_Bang; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $ast = $self->{assertion} ? $self->{assertion}->re_ast
: RE_noop->new;
$ast->{nobind} = 1;
RE_assertion->new(assert => '!', re => $ast);
}
}
{ package VAST::assertion__S_Bra; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $cclass = $self->Str;
$cclass =~ s/\\x([0-9a-fA-F]{3,4})/\\x\{$1\}/g;
RE_cclass->new(text => $cclass);
}
}
{ package VAST::assertion__S_Minus; our @ISA = 'VAST::assertion__S_Bra';
}
{ package VAST::assertion__S_Plus; our @ISA = 'VAST::assertion__S_Bra';
}
{ package VAST::assertion__S_Cur_Ly; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
local $::NEEDMATCH = 0;
my $text = $self->{embeddedblock}{statementlist}->p5;
$text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
RE_block->new(body => $text, context => 'bool');
}
}
{ package VAST::assertion__S_DotDotDot; our @ISA = 'VAST::Base';
}
{ package VAST::assertion__S_method; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $ast = $self->{assertion}->re_ast;
$ast->{nobind} = 1;
$ast;
}
}
{ package VAST::assertion__S_name; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $name = $self->{longname}->Str;
if ($self->{nibbler}[0]) {
local $::DBA = $::DBA;
local $::RATCHET = $::RATCHET;
local $::SIGSPACE = $::SIGSPACE;
local $::IGNORECASE = $::IGNORECASE;
return RE_method_re->new(name => $name,
re => $self->{nibbler}[0]{"."}->re_ast);
}
if ($self->{assertion}[0]) {
return RE_bindnamed->new(var => $name,
atom => $self->{assertion}[0]->re_ast);
}
if ($name eq 'sym' && defined $::ENDSYM) {
return RE_sequence->new(
RE_method->new(name => $name, sym => $::SYM),
RE_method->new(name => $::ENDSYM, nobind => 1));
}
my $al = $self->{arglist}[0];
local $::NEEDMATCH = 0;
$al = defined $al ? "(" . $al->p5 . ")" : undef;
RE_method->new(name => $name, ($name eq 'sym' ? (sym => $::SYM) : ()),
rest => $al, need_match => $::NEEDMATCH);
}
}
{ package VAST::assertion__S_Question; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $ast = $self->{assertion} ? $self->{assertion}->re_ast
: RE_noop->new;
$ast->{nobind} = 1;
RE_assertion->new(assert => '?', re => $ast);
}
}
{ package VAST::atom; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
if (exists $self->{TEXT}) {
RE_string->new(text => $self->{TEXT});
} else {
$self->{metachar}->re_ast;
}
}
}
{ package VAST::Autoincrement; our @ISA = 'VAST::Base';
}
{ package VAST::babble; our @ISA = 'VAST::Base';
}
{ package VAST::backslash; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_Back; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_d; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_h; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_misc; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_n; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_s; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_stopper; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_t; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_v; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_w; our @ISA = 'VAST::Base';
}
{ package VAST::backslash__S_x; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[1] = "{$t[1]}";
@t;
}
}
{ package VAST::before; our @ISA = 'VAST::Base';
}
{ package VAST::block; our @ISA = 'VAST::Base';
}
{ package VAST::blockoid; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
"{\n" . ::indent(scalar($self->{statementlist}->p5), 1) . "}";
}
}
{ package VAST::capterm; our @ISA = 'VAST::Base';
}
{ package VAST::cclass_elem; our @ISA = 'VAST::Base';
}
{ package VAST::Chaining; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::circumfix; our @ISA = 'VAST::Base';
}
{ package VAST::circumfix__S_Bra_Ket; our @ISA = 'VAST::Base';
}
{ package VAST::circumfix__S_Cur_Ly; our @ISA = 'VAST::Base';
}
{ package VAST::circumfix__S_Paren_Thesis; our @ISA = 'VAST::Base';
}
{ package VAST::circumfix__S_sigil; our @ISA = 'VAST::Base';
}
{ package VAST::codeblock; our @ISA = 'VAST::Base';
}
{ package VAST::colonpair; our @ISA = 'VAST::Base';
sub adverbs { my $self = shift;
my $val;
if (Scalar::Util::blessed $self->{v} &&
$self->{v}->isa('VAST::coloncircumfix')) {
my $s = $self->{v}->Str;
my $val = $s =~ /^<\s*(.*?)\s*>$/ ? ::unsingle($1) :
$s =~ /^«\s*(.*?)\s*»$/ ? ::undouble($1) :
$s =~ /^\['(.*)'\]$/ ? ::unsingle($1) :
die "Unparsable coloncircumfix";
return $self->{k} => $val;
} elsif ($self->{v} == 1) {
return "sym" => $self->{k};
} else {
die "Unsupported compile-time adverb " . $self->Str;
}
}
}
{ package VAST::Comma; our @ISA = 'VAST::Base';
}
{ package VAST::comp_unit; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
"use 5.010;\nuse utf8;\n" . $self->{statementlist}->p5, "\n";
}
sub emit_p6 { my $self = shift;
substr($ORIG, 0, $self->{statementlist}{BEG}),
$self->{statementlist}->p5;
}
sub emit_psq { my $self = shift;
local %::PRELUDE;
my $body = $self->{statementlist}->psq;
for (sort keys %::PRELUDE) {
my $fn = $_;
$fn =~ s#::#/#g;
$body = "use \"$fn.psq\";\n$body";
}
$body;
}
}
{ package VAST::Concatenation; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::Conditional; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
for (@t) {
s/\?\?/?/;
s/!!/:/;
}
@t;
}
}
{ package VAST::CORE; our @ISA = 'VAST::Base';
}
{ package VAST::declarator; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
if ($self->{signature}) {
return "(" . join(", ", map { $_->{param_var}->Str }
$self->{signature}->kids('parameter')) . ")";
} else {
return $self->SUPER::emit_p5;
}
}
sub emit_psq { my $self = shift;
if ($self->{variable_declarator}) {
$self->{variable_declarator}->psq(@_);
} elsif ($self->{signature}) {
$self->{signature}->psq(@_, declaring => 1);
} elsif ($self->{routine_declarator}) {
$self->{routine_declarator}->psq(@_);
} elsif ($self->{regex_declarator}) {
$self->{regex_declarator}->psq(@_);
} elsif ($self->{type_declarator}) {
$self->{type_declarator}->psq(@_);
}
}
}
{ package VAST::default_value; our @ISA = 'VAST::Base';
}
{ package VAST::deflongname; our @ISA = 'VAST::Base';
sub adverbs { my $self = shift;
map { $_->adverbs } $self->kids('colonpair');
}
}
{ package VAST::def_module_name; our @ISA = 'VAST::Base';
}
{ package VAST::desigilname; our @ISA = 'VAST::Base';
}
{ package VAST::dotty; our @ISA = 'VAST::Base';
}
{ package VAST::dotty__S_Dot; our @ISA = 'VAST::Methodcall';
}
{ package VAST::SYM_dotty__S_Dot; our @ISA = 'VAST::Base';
}
{ package VAST::dottyop; our @ISA = 'VAST::Base';
}
{ package VAST::eat_terminator; our @ISA = 'VAST::Base';
}
{ package VAST::escape; our @ISA = 'VAST::Base';
}
{ package VAST::escape__S_At; our @ISA = 'VAST::Base';
}
{ package VAST::escape__S_Back; our @ISA = 'VAST::Base';
}
{ package VAST::escape__S_Dollar; our @ISA = 'VAST::Base';
}
{ package VAST::EXPR; our @ISA = 'VAST::Base';
}
{ package VAST::fatarrow; our @ISA = 'VAST::Base';
}
{ package VAST::fulltypename; our @ISA = 'VAST::Base';
}
{ package VAST::hexint; our @ISA = 'VAST::Base';
}
{ package VAST::ident; our @ISA = 'VAST::Base';
}
{ package VAST::identifier; our @ISA = 'VAST::Base';
}
{ package VAST::index; our @ISA = 'VAST::Base';
}
{ package VAST::infix; our @ISA = 'VAST::Base';
}
{ package VAST::infix_prefix_meta_operator__S_Bang; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[1] = '~' if $t[1] eq '=~';
$t[1] = '=' if $t[1] eq '==';
@t = ('ne', '') if $t[1] eq 'eq';
@t;
}
}
{ package VAST::SYM_infix__S_ColonEqual; our @ISA = 'VAST::Item_assignment';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '='; # XXX oversimplified
@t;
}
}
{ package VAST::SYM_infix__S_ColonColonEqual; our @ISA = 'VAST::Item_assignment';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '='; # XXX oversimplified
@t;
}
}
{ package VAST::infixish; our @ISA = 'VAST::Base';
}
{ package VAST::SYM_infix__S_PlusAmp; our @ISA = 'VAST::Multiplicative';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '&';
@t;
}
}
{ package VAST::SYM_infix__S_eqv; our @ISA = 'VAST::Chaining';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = 'eq';
@t;
}
}
{ package VAST::SYM_infix__S_leg; our @ISA = 'VAST::Structural_infix';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = 'cmp';
@t;
}
}
{ package VAST::SYM_infix__S_EqualEqualEqual; our @ISA = 'VAST::Chaining';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '=='; # only correct for objects (and ints)
@t;
}
}
{ package VAST::SYM_infix__S_orelse; our @ISA = 'VAST::Loose_or';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = ' or ';
@t;
}
}
{ package VAST::SYM_infix__S_andthen; our @ISA = 'VAST::Loose_and';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = ' and ';
@t;
}
}
{ package VAST::SYM_infix__S_PlusVert; our @ISA = 'VAST::Additive';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '|';
@t;
}
}
{ package VAST::SYM_infix__S_Tilde; our @ISA = 'VAST::Concatenation';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '.';
@t;
}
}
{ package VAST::SYM_infix__S_TildeTilde; our @ISA = 'VAST::Chaining';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '=~';
@t;
}
}
{ package VAST::SYM_infix__S_TildeVert; our @ISA = 'VAST::Additive';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '|';
@t;
}
}
{ package VAST::integer; our @ISA = 'VAST::Base';
}
{ package VAST::Item_assignment; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::Junctive_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::label; our @ISA = 'VAST::Base';
}
{ package VAST::lambda; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = 'sub';
@t;
}
}
{ package VAST::left; our @ISA = 'VAST::Base';
}
{ package VAST::List_assignment; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::litchar; our @ISA = 'VAST::Base';
}
{ package VAST::longname; our @ISA = 'VAST::Base';
sub adverbs { my $self = shift;
map { $_->adverbs } $self->kids('colonpair');
}
}
{ package VAST::Loose_and; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::Loose_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::Loose_unary; our @ISA = 'VAST::Base';
}
{ package VAST::metachar; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
RE_meta->new(text => $self->Str);
}
}
{ package VAST::metachar__S_Back; our @ISA = 'VAST::metachar';
sub re_ast { my $self = shift;
RE_meta->new(text => $self->Str, min => 1);
}
}
{ package VAST::metachar__S_Bra_Ket; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
local $::DBA = $::DBA;
local $::RATCHET = $::RATCHET;
local $::SIGSPACE = $::SIGSPACE;
local $::IGNORECASE = $::IGNORECASE;
local @::DECLAST;
my $bodyast = $self->{nibbler}{"."}->re_ast;
RE_bracket->new(decl => \@::DECLAST, re => $bodyast);
}
}
{ package VAST::metachar__S_Caret; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_CaretCaret; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_ColonColon; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_ColonColonColon; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_ColonColonKet; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_Cur_Ly; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
local $::NEEDMATCH = 0;
my $text = $self->{embeddedblock}{statementlist}->p5;
$text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
RE_block->new(body => $text, context => 'void');
}
}
{ package VAST::metachar__S_Dollar; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_DollarDollar; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_Dot; our @ISA = 'VAST::metachar';
sub re_ast { my $self = shift;
RE_meta->new(text => $self->Str, min => 1);
}
}
{ package VAST::metachar__S_Double_Double; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $text = ::undouble($self->{quote}{nibble}->Str);
RE_double->new(text => $text);
}
}
{ package VAST::metachar__S_Lt_Gt; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$self->{assertion}->re_ast;
}
}
{ package VAST::metachar__S_mod; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$self->{mod_internal}->re_ast;
}
}
{ package VAST::metachar__S_Nch; our @ISA = 'VAST::metachar';
}
{ package VAST::metachar__S_Paren_Thesis; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
local $::DBA = $::DBA;
local $::RATCHET = $::RATCHET;
local $::SIGSPACE = $::SIGSPACE;
local $::IGNORECASE = $::IGNORECASE;
local @::DECLAST;
my $bodyast = $self->{nibbler}{"."}->re_ast;
# XXX STD gimme5 disables binding to $0 in $<foo> = (bar)
my $inner = RE_paren->new(decl => \@::DECLAST, re => $bodyast);
$::PARSENAME ? $inner : RE_bindpos->new(var => $::PAREN++, atom => $inner)
}
}
{ package VAST::metachar__S_qw; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
# XXX
my @elems = split(' ', $self->{circumfix}{nibble}->Str);
shift @elems;
my $l = ::min(1_000_000_000, map { length } @elems);
RE_qw->new(min => $l, text => $self->Str);
}
}
{ package VAST::metachar__S_sigwhite; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$::SIGSPACE ?
RE_method->new(name => 'ws', nobind => 1) :
RE_noop->new;
}
}
{ package VAST::metachar__S_Single_Single; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $text = ::unsingle($self->{quote}{nibble}->Str);
RE_string->new(text => $text);
}
}
{ package VAST::metachar__S_var; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
# We don't un6 because some things need to un6 specially - backrefs
if ($self->{binding}) {
local $::PARSENAME = 1;
$self->{SYM} =~ /^\$<(.*)>$/ or die "Can't bind backref to " . $self->{SYM};
RE_bindnamed->new(var => $1, atom =>
$self->{binding}{quantified_atom}->re_ast);
} else {
RE_var->new(var => $self->{termish}->p5);
}
}
}
{ package VAST::Methodcall; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if (@t > 2) {
my $first = shift @t;
my $second = join '', @t;
@t = ($first,$second);
}
if ($t[1] eq '.pos') { $t[1] = '.<_pos>'; }
$t[1] =~ s/^(\.?)<(.*)>$/$1\{'$2'\}/;
if ($t[0] =~ /^[@%]/) {
if ($t[1] =~ s/^\.?([[{])/$1/) {
if ($t[1] =~ /,/) {
substr($t[0],0,1) = '@';
}
else {
substr($t[0],0,1) = '$';
}
}
}
elsif ($t[1] =~ /^[[{]/) {
$t[1] =~ s/^([[{])/.$1/;
}
elsif ($t[0] =~ s/^&(\w+)/\$$1/) {
$t[1] =~ s/^\(/->(/;
}
$t[1] =~ s/^\./->/;
my $t = join('', @t);
$t =~ s/^(.*\S)\s*:(delete|exists)/$2 $1/;
# print STDERR ::Dump(\@t);
$t;
}
}
{ package VAST::method_def; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $name = $self->{longname} ? $self->{longname}->p5 . " " : "";
my $sig = $self->{multisig}[0] ? $self->{multisig}[0]->p5 : "";
my $body = $self->{blockoid}{statementlist}->p5;
if ($::MULTINESS eq 'multi') {
$::MULTIMETHODS{$name} .= <<EOT
{
local \@_ = \@_;
return scalar do { # work around #38809
my \$self = shift;
EOT
. ::indent($sig . $body, 2) . <<EOT
};
}
EOT
;
return '';
}
# not quite right, this should be an expression
($name eq 'EXPR' ? # XXX STD
"sub EXPR__PEEK { \$_[0]->_AUTOLEXpeek(\'EXPR\',\$retree) }\n" : '').
"sub " . $name . "{\n" .
::indent("no warnings 'recursion';\nmy \$self = shift;\n" .
$sig . $body, 1)
. "}";
}
}
{ package VAST::methodop; our @ISA = 'VAST::Base';
}
{ package VAST::modifier_expr; our @ISA = 'VAST::Base';
}
{ package VAST::mod_internal; our @ISA = 'VAST::Base';
}
{ package VAST::mod_internal__S_p6adv; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my $key = $self->{quotepair}{k};
if ($key eq 'dba') {
$::DBA = eval ($self->{quotepair}{circumfix}[0]->Str);
} elsif ($key eq 'lang') {
my $lang = $self->{quotepair}{circumfix}[0]->p5;
return RE_decl->new(body => <<BODY);
my \$newlang = $lang;
\$C = bless(\$C, (ref(\$newlang) || \$newlang));
BODY
} else {
die "unhandled internal adverb $key";
}
RE_noop->new;
}
}
{ package VAST::mod_internal__S_ColonBangs; our @ISA = 'VAST::Base';
}
{ package VAST::mod_internal__S_Coloni; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$::IGNORECASE = 1;
RE_noop->new;
}
}
{ package VAST::mod_internal__S_Colonr; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$::RATCHET = 1;
RE_noop->new;
}
}
{ package VAST::mod_internal__S_Colonmy; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
local $::NEEDMATCH = 0;
my $text = $self->{statement}->p5 . ";";
$text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
push @::DECLAST, RE_decl->new(body => $text);
RE_noop->new;
}
}
{ package VAST::mod_internal__S_Colons; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$::SIGSPACE = 1;
RE_noop->new;
}
}
{ package VAST::mod_internal__S_ColonBangs; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
$::SIGSPACE = 0;
RE_noop->new;
}
}
{ package VAST::module_name; our @ISA = 'VAST::Base';
}
{ package VAST::module_name__S_normal; our @ISA = 'VAST::Base';
}
{ package VAST::morename; our @ISA = 'VAST::Base';
}
{ package VAST::multi_declarator; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
if ($self->{declarator}) {
$self->{declarator}->psq(@_, multiness => $self->{SYM});
} else {
$self->{routine_def}->psq(@_, multiness => $self->{SYM});
}
}
}
{ package VAST::multi_declarator__S_multi; our @ISA = 'VAST::multi_declarator';
sub emit_p5 { my $self = shift;
local $::MULTINESS = 'multi';
$self->{"."}->p5;
}
}
{ package VAST::multi_declarator__S_null; our @ISA = 'VAST::multi_declarator';
}
{ package VAST::multi_declarator__S_proto; our @ISA = 'VAST::multi_declarator';
sub emit_p5 { my $self = shift;
local $::MULTINESS = 'proto';
$self->{"."}->p5;
}
}
{ package VAST::Multiplicative; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
# We don't currently do MMD so no need for later sigs
{ package VAST::multisig; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
$self->{signature}[0]->p5;
}
}
{ package VAST::name; our @ISA = 'VAST::Base';
}
{ package VAST::named_param; our @ISA = 'VAST::Base';
}
{ package VAST::Named_unary; our @ISA = 'VAST::Base';
}
{ package VAST::nibbler; our @ISA = 'VAST::Base';
}
{ package VAST::nofun; our @ISA = 'VAST::Base';
}
{ package VAST::normspace; our @ISA = 'VAST::Base';
}
{ package VAST::nulltermish; our @ISA = 'VAST::Base';
}
{ package VAST::number; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
die "unsupported literal format" unless $self->{integer}{decint};
my $str = $self->{integer}{decint}->Str;
$str =~ y/_//d;
$str;
}
}
{ package VAST::number__S_numish; our @ISA = 'VAST::Base';
}
{ package VAST::numish; our @ISA = 'VAST::Base';
}
{ package VAST::opener; our @ISA = 'VAST::Base';
}
{ package VAST::package_declarator; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
local $::PKGDECL = $self->{SYM};
$self->{package_def}->psq;
}
}
{ package VAST::package_declarator__S_class; our @ISA = 'VAST::package_declarator';
sub emit_p5 { my $self = shift;
local $::PKGDECL = 'class';
$self->{package_def}->p5;
}
}
{ package VAST::package_declarator__S_grammar; our @ISA = 'VAST::package_declarator';
sub emit_p5 { my $self = shift;
local $::PKGDECL = 'grammar';
$self->{package_def}->p5;
}
}
{ package VAST::package_declarator__S_role; our @ISA = 'VAST::package_declarator';
sub emit_p5 { my $self = shift;
local $::PKGDECL = 'role';
$self->{package_def}->p5;
}
}
{ package VAST::package_declarator__S_knowhow; our @ISA = 'VAST::package_declarator';
sub emit_p5 { my $self = shift;
local $::PKGDECL = 'knowhow';
$self->{package_def}->p5;
}
}
{ package VAST::package_def; our @ISA = 'VAST::Base';
sub module_name { my $self = shift;
my $def_module_name = $self->{longname}[0]{name}->Str;
if ($self->{decl}{inpkg}[0] =~ /GLOBAL::(.*)/) {
my $mod = $1;
for ($mod) { s/::::/::/g; s/^:://; s/::$//; } # XXX STD misparse?
$::OUR{$def_module_name} = "${mod}::$def_module_name";
$def_module_name = "${mod}::$def_module_name";
}
$def_module_name;
}
sub superclasses { my $self = shift;
my @extends;
for (@{$self->{trait}}) {
my $t = $_->Str;
push(@extends, $t =~ /^is\s+(\S+)/);
}
@extends = map { $::OUR{$_} // $_ } @extends;
@extends = 'STD::Cursor' if $::PKGDECL eq 'grammar' && !@extends;
@extends;
}
sub roles { my $self = shift;
my @does;
for (@{$self->{trait}}) {
my $t = $_->Str;
push(@does, $t =~ /^does\s+(\S+)/);
}
@does = map { $::OUR{$_} // $_ } @does;
}
sub emit_p5_header { my $self = shift;
my $header = "";
my $name = $::PKG;
my $meta = $::PKGDECL eq 'role' ? 'Moose::Role' : 'Moose';
$header .= <<"END";
use $meta ':all' => { -prefix => "moose_" };
use Encode;
END
$header .= <<"END" for $self->superclasses;
moose_extends('$_');
END
$header .= <<"END" for $self->roles;
moose_with('$_');
END
if (! $self->roles) {
$header .= "our \$ALLROLES = { '$::PKG', 1 };\n";
}
$header .= "our \$REGEXES = {\n";
$::PROTORX_HERE{ALL} = [ sort keys %::OVERRIDERX ];
for my $p (sort keys %::PROTORX_HERE) {
$header .= " $p => [ qw/" . join(" ",
@{ $::PROTORX_HERE{$p} }) . "/ ],\n";
}
$header .= "};\n\n";
$header .= <<"END";
no warnings 'qw', 'recursion';
my \$retree;
\$DB::deep = \$DB::deep = 1000; # suppress used-once warning
use YAML::XS;
\$SIG{__WARN__} = sub { die \@_," statement started at line ", 'STD::Cursor'->lineof(\$::LASTSTATE), "\n" } if \$::DEBUG;
END
$header;
}
sub emit_p5 { my $self = shift;
my $block = $self->{blockoid}{statementlist} // $self->{statementlist};
local $::RETREE = {};
local $::PKG = $self->module_name;
local $::MULTIRX_SEQUENCE = 0;
local %::PROTORX_HERE;
local %::OVERRIDERX;
local %::MULTIMETHODS;
my $body3 = $block->p5;
my $body1 = $self->emit_p5_header;
my $body2 = '';
if (%{$::RETREE}) {
$body2 = "\$retree = YAML::XS::Load(Encode::encode_utf8(<<'RETREE_END'));\n" .
Encode::decode_utf8(::Dump($::RETREE)) . "RETREE_END\n";
}
my $body = $body1 . $body2 . $body3;
my $name = $::PKG;
if (my ($sig) = $self->kids('signature')) {
my @parm = map { $_->Str } $sig->kids('parameter');
my $plist = join ", ", @parm;
$body = <<EOT . $body;
package $name;
require "mangle.pl";
our \%INSTANTIATED;
sub __instantiate__ { my \$self = shift;
my ($plist) = \@_;
my \$mangle = ::mangle($plist);
my \$mixin = "${name}::" . \$mangle;
return \$mixin if \$INSTANTIATED{\$mixin}++;
::deb(" instantiating \$mixin") if \$::DEBUG & DEBUG::mixins;
my \$eval = "package \$mixin" . q{;
sub _PARAMS { { ${\ join(", ", map { "'$_' => $_" } @parm) } } }
EOT
$body .= <<EOT;
};
eval \$eval;
die \$@ if \$@;
return \$mixin;
}
EOT
} else {
$body = "package $name;\n" . $body;
}
my $finalmulti = '';
for my $mm (sort keys %::MULTIMETHODS) {
$finalmulti .= "moose_around $mm => sub {\n my \$orig = shift;\n no warnings 'recursion';\n" .
::indent($::MULTIMETHODS{$mm}, 1) . <<EOFINAL
\$orig->(\@_);
};
EOFINAL
;
}
"{ $body $finalmulti 1; }";
}
sub psq_finish_multis { my $self = shift;
die "multis not yet implemented for psq";
}
sub psq_retree { my $self = shift;
die "LTM not yet implemented for psq";
}
sub psq_parameterized { my $self = shift;
die "roles not yet implemented for psq";
}
sub psq_plain { my $self = shift; my $body = shift;
die "roles not yet implemented for psq"
if $::PKGDECL eq 'role' or $self->roles;
die "multiple inheritance not available in psq"
if $self->superclasses > 1;
my ($is) = $self->superclasses;
"class " . $::PKG . " " . ($is ? "is $is " : "") .
"{\n" . ::indent($body) . "\n}";
}
sub emit_psq { my $self = shift;
my $block = $self->{blockoid}{statementlist} // $self->{statementlist};
local $::RETREE = {};
local $::PKG = $self->module_name;
local $::MULTIRX_SEQUENCE = 0;
local %::MULTIMETHODS;
my $body = $block->psq;
$body = $body . $self->psq_finish_multis
if %::MULTIMETHODS;
$body = $self->psq_retree . $body
if %$::RETREE;
if (my ($sig) = $self->kids('signature')) {
$body = $self->psq_parameterized($body,
map { $_->Str } $sig->kids('parameter'));
} else {
$body = $self->psq_plain($body);
}
$body;
}
}
# Perl5 invocations don't carry enough context for a proper binder; in
# particular we can't distinguish named stuff from positionals
{ package VAST::parameter; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $pvar = $self->{param_var};
my @names;
my $posit = 0;
my $np = $self->{named_param};
while ($np) {
$pvar = $np->{param_var};
push @names, $np->{name} ? $np->{name}{TEXT}
: $np->{param_var}{name}[0]{TEXT};
$np = $np->{named_param};
}
$posit = 1 unless @names;
my $pname = $pvar->{name}[0]{TEXT};
my $sigil = $pvar->{sigil}{SYM};
my $twigil = $pvar->{twigil}[0] ? $pvar->{twigil}[0]{SYM} : '';
my ($dv) = $self->kids('default_value');
# Is it valid?
my $check = '';
if (($self->{quant} eq '!' || $self->{quant} eq '' && $posit) && !$dv) {
$check .= $::MULTINESS eq 'multi' ? "last " :
"die 'Required argument $pname omitted' ";
$check .= $posit ? 'unless @_'
: 'unless ' . join(" || ", map ("exists \$args{$_}", @names));
$check .= ";\n"
}
# Get the value
my $value = "undef";
if ($dv) {
$value = $dv->{"."}->p5;
}
if ($posit) {
$value = '@_ ? shift() : ' . $value;
}
for (reverse @names) {
$value = "exists \$args{$_} ? delete \$args{$_} : $value";
}
if ($self->{quant} eq '*') {
$value = ($sigil eq '%') ? '%args' : '@_';
$posit = 0 if $sigil eq '%';
}
# Store it somewhere useful
if ($twigil eq '*' && $pname eq 'endsym') {
# XXX this optimization needs to be refactored, I think
my ($dv) = $self->kids('default_value');
$::ENDSYM = $dv->{"."}->Str;
$::ENDSYM = substr($::ENDSYM, 1, length($::ENDSYM)-2);
return (0, '');
}
my $assn;
if ($twigil eq '*') {
$assn = "local ${sigil}::${pname} = $value";
} else {
$assn = "my ${sigil}${pname} = $value";
}
(!$posit), ($check . $assn);
}
}
{ package VAST::param_sep; our @ISA = 'VAST::Base';
}
{ package VAST::param_var; our @ISA = 'VAST::Base';
}
{ package VAST::pblock; our @ISA = 'VAST::Base';
}
{ package VAST::pod_comment; our @ISA = 'VAST::Base';
}
{ package VAST::POST; our @ISA = 'VAST::Base';
}
{ package VAST::postcircumfix; our @ISA = 'VAST::Base';
}
{ package VAST::SYM_postcircumfix__S_Lt_Gt; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = "{'";
$t[-1] = "'}";
@t;
}
}
{ package VAST::postfix; our @ISA = 'VAST::Base';
}
{ package VAST::postop; our @ISA = 'VAST::Base';
}
{ package VAST::PRE; our @ISA = 'VAST::Base';
}
{ package VAST::prefix; our @ISA = 'VAST::Base';
}
{ package VAST::SYM_prefix__S_Plus; our @ISA = 'VAST::Symbolic_unary';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '0+';
@t;
}
}
{ package VAST::SYM_prefix__S_Vert; our @ISA = 'VAST::Symbolic_unary';
sub emit_p5 { my $self = shift;
('');
}
}
{ package VAST::prefix__S_temp; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $arg = $self->{arg}->p5;
"local $arg = $arg";
}
}
{ package VAST::quantified_atom; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
if (!@{$self->{quantifier}}) {
return $self->{atom}->re_ast;
}
if ($self->{quantifier}[0]{SYM} eq '~') {
return $self->_tilde;
}
if ($self->{quantifier}[0]{SYM} eq ':') {
my $ast = $self->{atom}->re_ast;
$ast->{r} = 1;
return $ast;
}
my $quant = $self->{quantifier}[0]->re_quantifier;
my $ast = $self->{atom}->re_ast;
my $r = RE_quantified_atom->new(atom => $ast, quant => $quant);
$r->{r} = 0 if $quant->[1] ne ':';
$r;
}
sub _tilde { my $self = shift;
my $opener = $self->{atom}->re_ast;
my $closer = $self->{quantifier}[0]{quantified_atom}[0]->re_ast;
my $inner = $self->{quantifier}[0]{quantified_atom}[1]->re_ast;
my $strcloser = $closer->{text}; #XXX
my $begin = <<TEXT;
local \$::GOAL = "${\ quotemeta $strcloser}";
my \$goalpos = \$C;
TEXT
if ($strcloser !~ /^[])}]$/) {
$begin .= <<TEXT;
my \$newlang = \$C->unbalanced(\$::GOAL);
\$C = bless(\$C, (ref(\$newlang) || \$newlang));
TEXT
}
my @expn;
push @expn, $opener;
# XXX STD break LTM for gimme5 bug-compatibility
push @expn, RE_block->new(body => '', context => 'void');
push @expn, $inner;
push @expn, RE_bracket->new(decl => [], re => RE_first->new(
RE_string->new(text => $strcloser),
RE_method->new(name => 'FAILGOAL', nobind => 1,
rest => "(\$::GOAL, '$::DBA', \$goalpos)")));
RE_bracket->new(decl => [RE_decl->new(body => $begin)], re =>
RE_sequence->new(@expn));
}
}
{ package VAST::quant_atom_list; our @ISA = 'VAST::Base';
sub re_ast { my $self = shift;
my @kids = map { $_->re_ast } $self->kids("quantified_atom");
RE_sequence->new(@kids);
}
}
{ package VAST::quantifier; our @ISA = 'VAST::Base';
}
{ package VAST::quantifier__S_Plus; our @ISA = 'VAST::Base';
sub re_quantifier { my $self = shift;
$self->base_re_quantifier("", 1);
}
}
{ package VAST::quantifier__S_Question; our @ISA = 'VAST::Base';
sub re_quantifier { my $self = shift;
$self->base_re_quantifier("", 0);
}
}
{ package VAST::quantifier__S_Star; our @ISA = 'VAST::Base';
sub re_quantifier { my $self = shift;
$self->base_re_quantifier("", 0);
}
}
{ package VAST::quantifier__S_StarStar; our @ISA = 'VAST::Base';
sub re_quantifier { my $self = shift;
my ($range) = $self->Str =~ /.*(\d+\.\.\d+)$/;
$self->base_re_quantifier($self->{embeddedblock} //
$range // $self->{quantified_atom}->re_ast, 1);
}
}
{ package VAST::quantmod; our @ISA = 'VAST::Base';
}
{ package VAST::quibble; our @ISA = 'VAST::Base';
}
{ package VAST::quote; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] =~ s/</qw</;
# print STDERR ::Dump(\@t);
@t;
}
}
{ package VAST::quote__S_Double_Double; our @ISA = 'VAST::Base';
}
{ package VAST::circumfix__S_Fre_Nch; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
'[split(/ /, "' . $self->{nibble}->p5 . '", -1)]'
}
}
{ package VAST::quote__S_Lt_Gt; our @ISA = 'VAST::Base';
}
{ package VAST::quotepair; our @ISA = 'VAST::Base';
}
{ package VAST::quote__S_s; our @ISA = 'VAST::Base';
}
{ package VAST::quote__S_Single_Single; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
my $str = $self->Str;
$str;
}
}
{ package VAST::quote__S_Slash_Slash; our @ISA = 'VAST::Base';
}
{ package VAST::regex_block; our @ISA = 'VAST::Base';
}
{ package VAST::regex_declarator; our @ISA = 'VAST::Base';
}
{ 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;
$::PROTO->{$name} = 1;
$::RETREE->{$name . ":*"} = { dic => $::PKG };
$::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;
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 = $::PROTO && $::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'));
}
}
# type erase
{ package VAST::scoped; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
if (@{$self->{typename}}) {
" " . $self->{multi_declarator}->p5;
} else {
$self->SUPER::emit_p5;
}
}
sub emit_psq { my $self = shift; my $scope = shift;
if ($self->{multi_declarator}) {
$self->{multi_declarator}->psq(scope => $scope,
typename => $self->{typename}[0]->psq);
} elsif ($self->{regex_declarator}) {
$self->{regex_declarator}->psq(scope => $scope);
} elsif ($self->{package_declarator}) {
$self->{package_declarator}->psq(scope => $scope);
} else {
$self->{declarator}->psq(scope => $scope);
}
}
}
{ package VAST::scope_declarator; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
$self->{scoped}->psq($self->{SYM});
}
}
{ package VAST::scope_declarator__S_has; our @ISA = 'VAST::scope_declarator';
sub emit_p5 { my $self = shift;
my $scoped = $self->{scoped};
my $typename = $scoped->{typename}[0];
my $multi = $scoped->{multi_declarator};
my $decl = $scoped->{declarator} // $multi->{declarator};
my $vdecl = $decl->{variable_declarator};
my $var = $vdecl->{variable};
"moose_has '" . $var->{desigilname}->Str . "' => (" . join (", ",
($typename ? ("isa => '" . $typename->Str . "'") : ()),
("is => 'rw'")
) . ")";
}
}
{ package VAST::scope_declarator__S_my; our @ISA = 'VAST::scope_declarator';
sub emit_p5 { my $self = shift;
my $t = $self->SUPER::emit_p5;
$t =~ s/my(\s+)&(\w+)/my$1\$$2/;
$t =~ s/my(\s+)([\$@%])::(\w+)/local$1${2}::$3/;
$t;
}
}
{ package VAST::scope_declarator__S_our; our @ISA = 'VAST::scope_declarator';
}
{ package VAST::semiarglist; our @ISA = 'VAST::Base';
}
{ package VAST::semilist; our @ISA = 'VAST::Base';
}
{ package VAST::sibble; our @ISA = 'VAST::Base';
}
{ package VAST::sigil; our @ISA = 'VAST::Base';
my %psq_hash = ( '$', 'S', '@', 'A', '%', 'H', '&', 'C' );
sub psq_mangle { my $self = shift;
return $psq_hash{$self->{SYM}};
}
}
{ package VAST::sigil__S_Amp; our @ISA = 'VAST::sigil';
}
{ package VAST::sigil__S_At; our @ISA = 'VAST::sigil';
}
{ package VAST::sigil__S_Dollar; our @ISA = 'VAST::sigil';
}
{ package VAST::sigil__S_Percent; our @ISA = 'VAST::sigil';
}
{ package VAST::sign; our @ISA = 'VAST::Base';
}
{ package VAST::signature; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
for ($self->kids('param_sep')) {
next if $_->{TEXT} =~ /,/;
die "Unusual parameter separators not yet supported";
}
# signature stuff is just parsing code
my @seg = ('', '');
for my $pv ($self->kids('parameter')) {
my ($named, $st) = $pv->p5;
$seg[$named] .= $st . ";\n";
}
if ($seg[1]) { $seg[1] = "my %args = \@_;\n" . $seg[1]; }
$seg[0] . $seg[1];
}
}
{ package VAST::spacey; our @ISA = 'VAST::Base';
}
{ package VAST::special_variable; our @ISA = 'VAST::Base';
}
{ package VAST::special_variable__S_Dollar_a2_; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '$C';
@t;
}
}
{ package VAST::special_variable__S_DollarSlash; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '$M';
$::NEEDMATCH++;
@t;
}
}
{ package VAST::statement; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
if ($self->{label}) {
return $self->{label}{identifier}->Str . ":\n" .
$self->{statement}->psq;
}
if ($self->{statement_control}) {
return $self->{statement_control}->psq;
}
return "" if !$self->{EXPR};
my $body = $self->{EXPR}->psq . ";";
for my $m ($self->kids('statement_mod_cond'),
$self->kids('statement_mod_loop')) {
$body = $m->psq . " {\n" . ::indent($body) . "\n}";
}
$body;
}
}
{ package VAST::statement_control; our @ISA = 'VAST::Base';
}
{ package VAST::statement_control__S_default; our @ISA = 'VAST::Base';
}
{ package VAST::statement_control__S_use; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
$::PRELUDE{$self->{module_name}->Str} = 1;
"";
}
}
{ package VAST::statement_control__S_for; our @ISA = 'VAST::Base';
}
{ package VAST::statement_control__S_given; our @ISA = 'VAST::Base';
}
{ package VAST::statement_control__S_if; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
join("\n", ("if " . $self->{xblock}->p5)
, (map { "elsif " .$_->p5 } @{$self->{elsif}})
, (map { "else " . $_->p5 } @{$self->{else}}));
}
}
{ package VAST::statement_control__S_loop; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $t = $self->SUPER::emit_p5;
$t =~ s/^loop(\s+\()/for$1/;
$t =~ s/^loop/for (;;)/;
$t;
}
}
{ package VAST::statement_control__S_when; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if ($t[1] =~ s/^\s*\(\s*\*\s*\)//) { $t[0] = 'default'; }
@t;
}
}
{ package VAST::statement_control__S_while; our @ISA = 'VAST::Base';
}
{ package VAST::statementlist; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @stmts = $self->kids('statement');
# XXX mostly for the benefit of hashes
if (@stmts == 1) {
return $stmts[0]->p5;
}
join("", map { $_->p5 . ";\n" } @stmts);
}
sub emit_psq { my $self = shift;
my @stmts = $self->kids('statement');
local @::LEXVARS;
my $b = join("", map { $_->psq . "\n" } @stmts);
join("", @::LEXVARS, $b);
}
}
{ package VAST::statement_mod_cond; our @ISA = 'VAST::Base';
}
{ package VAST::statement_mod_cond__S_if; our @ISA = 'VAST::Base';
}
{ package VAST::statement_mod_cond__S_unless; our @ISA = 'VAST::Base';
}
{ package VAST::statement_mod_loop; our @ISA = 'VAST::Base';
}
{ package VAST::statement_mod_loop__S_for; our @ISA = 'VAST::Base';
}
{ package VAST::statement_mod_loop__S_while; our @ISA = 'VAST::Base';
}
{ package VAST::statement_prefix; our @ISA = 'VAST::Base';
}
{ package VAST::statement_prefix__S_do; our @ISA = 'VAST::Base';
}
{ package VAST::statement_prefix__S_try; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = 'eval';
@t;
}
}
{ package VAST::stdstopper; our @ISA = 'VAST::Base';
}
{ package VAST::stopper; our @ISA = 'VAST::Base';
}
{ package VAST::Structural_infix; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::sublongname; our @ISA = 'VAST::Base';
}
{ package VAST::subshortname; our @ISA = 'VAST::Base';
}
{ package VAST::Symbolic_unary; our @ISA = 'VAST::Base';
}
{ package VAST::term; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_capterm; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_circumfix; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_colonpair; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $t = $self->SUPER::emit_p5;
my $val;
if ($t =~ s/^:!//) {
$val = 0
}
elsif ($t =~ s/^:(\d+)//) {
$val = $1;
}
else {
$t =~ s/^://;
$val = 1;
}
if ($t =~ s/^(\w+)$/'$1'/) {
$t .= " => $val";
}
else {
my ($name,$rest) = $t =~ /^(\w+)(.*)$/s;
$rest =~ s/^<([^\s']*)>/'$1'/ or
$rest =~ s/^(<\S*>)/q$1/ or
$rest =~ s/^(<\s*\S+\s*>)/qw$1/ or
$rest =~ s/^(<.*>)/[qw$1]/; # p5's => isn't scalar context
$t = "'$name' => $rest";
}
$t;
}
}
{ package VAST::term__S_fatarrow; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_identifier; our @ISA = ('VAST::ViaDEEP', 'VAST::Base');
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if ($t[0] eq 'item') {
$t[0] = '\\';
$t[1] =~ s/^\s+//;
}
if ($t[0] eq 'map' || $t[0] eq 'grep' || $t[0] eq 'sort') {
# XXX this should be more robust, but it belongs in DEEP after
# all arguments are collected anyway
$t[1] =~ s/}\s*,/} /;
}
if ($t[0] eq 'invert') {
$t[0] = 'reverse';
}
if ($t[0] eq 'chars') {
$t[0] = 'length';
}
if ($t[0] eq 'note') {
$t[0] = 'print STDERR';
}
if ($t[0] eq 'False') {
$t[0] = '0';
}
if ($t[0] eq 'True') {
$t[0] = '1';
}
if ($t[0] eq 'Nil') {
$t[0] = '()';
}
@t;
}
sub _deep { my $self = shift;
my $id = $self->{identifier}->Str;
my @args = $self->{args}->deepn;
DEEP::call($id, @args);
}
}
{ package VAST::term__S_multi_declarator; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_package_declarator; our @ISA = 'VAST::Base';
sub emit_psq { $_[0]{package_declarator}->psq }
}
{ package VAST::term__S_regex_declarator; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;;
$self->{regex_declarator}->p5;
}
}
{ package VAST::term__S_routine_declarator; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_scope_declarator; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift;
$self->{scope_declarator}->psq;
}
}
{ package VAST::term__S_statement_prefix; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_term; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_value; our @ISA = 'VAST::Base';
sub emit_psq { $_[0]{value}->psq}
}
{ package VAST::term__S_variable; our @ISA = 'VAST::Base';
}
{ package VAST::terminator; our @ISA = 'VAST::Base';
sub emit_p6 { my $self = shift;
my @t = $self->SUPER::emit_p6;
'';
}
}
{ package VAST::terminator__S_BangBang; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_for; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_if; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_Ket; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_Ly; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_Semi; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_Thesis; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_unless; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_while; our @ISA = 'VAST::terminator'; }
{ package VAST::terminator__S_when; our @ISA = 'VAST::terminator'; }
{ package VAST::termish; our @ISA = 'VAST::Base';
}
{ package VAST::term; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_name; our @ISA = ('VAST::Base');
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if (my ($pkg) = ($t[0] =~ /^::(.*)/)) {
$pkg = $::OUR{$pkg} // $pkg;
if (defined $t[1] && $t[1] =~ /^\s*\[/) {
$t[1] =~ s/^\s*\[/->__instantiate__(/;
$t[1] =~ s/\]\s*$/)/;
$t[0] = "$pkg";
} else {
$t[0] = "'$pkg'";
}
}
@t;
}
}
{ package VAST::term__S_self; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '$self';
@t;
}
}
{ package VAST::term__S_Star; our @ISA = 'VAST::Base';
}
{ package VAST::term__S_undef; our @ISA = 'VAST::Base';
}
{ package VAST::Tight_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::Tight_and; our @ISA = ('VAST::Base', 'VAST::InfixCall');
}
{ package VAST::trait; our @ISA = 'VAST::Base';
}
{ package VAST::trait_auxiliary; our @ISA = 'VAST::Base';
}
{ package VAST::trait_auxiliary__S_does; our @ISA = 'VAST::Base';
}
{ package VAST::trait_auxiliary__S_is; our @ISA = 'VAST::Base';
}
{ package VAST::twigil; our @ISA = 'VAST::Base';
}
{ package VAST::twigil__S_Dot; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = 'self->'; # XXX
@t;
}
}
{ package VAST::twigil__S_Star; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '::';
@t;
}
}
{ package VAST::twigil__S_Caret; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = ''; #XXX only correct for sorts
@t;
}
}
{ package VAST::type_constraint; our @ISA = 'VAST::Base';
}
{ package VAST::type_declarator__S_constant; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my $t = $self->SUPER::emit_p5;
$t =~ s/constant/our/;
$t;
}
}
{ package VAST::typename; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t;
if (ref $context[-1] ne 'VAST::scoped') {
@t = $self->SUPER::emit_p5;
}
@t;
}
sub emit_psq { my $self = shift;
my $s = $self->Str;
$s eq 'Str' && return 'str';
$s eq 'Int' && return 'int';
$s;
}
}
{ package VAST::unitstopper; our @ISA = 'VAST::Base';
}
{ package VAST::unspacey; our @ISA = 'VAST::Base';
}
{ package VAST::unv; our @ISA = 'VAST::Base';
}
{ package VAST::val; our @ISA = 'VAST::Base';
}
{ package VAST::value; our @ISA = 'VAST::Base';
}
{ package VAST::value__S_number; our @ISA = 'VAST::Base';
sub emit_psq { $_[0]{number}->psq}
}
{ package VAST::value__S_quote; our @ISA = 'VAST::Base';
sub emit_psq { $_[0]{quote}->psq}
}
{ package VAST::variable; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
if (@t >= 2) { # $t[0] eq '$' but XXX STD uses %<O><prec> (erroneously?)
if ($t[1] =~ /^\d+$/) {
$t[1] = "M->{$t[1]}";
$::NEEDMATCH = 1;
} elsif ($t[1] =~ /^{/) {
$t[0] = "\$M->";
$::NEEDMATCH = 1;
}
}
@t;
}
sub emit_psq { my $self = shift;
return '$' . $self->{sigil}->psq_mangle . '_' . $self->{desigilname}->Str;
}
}
{ package VAST::variable_declarator; our @ISA = 'VAST::Base';
sub emit_psq { my $self = shift; my %args = @_;
my $scope = $args{scope};
my $type = $args{typename};
my $var = $self->{variable}->psq;
my $s = $self->{variable}{sigil}{SYM};
if ($scope eq 'my') {
die "Variables in Perlesque *must* be typed" unless $type;
push @::LEXVARS, "my $type $var;\n" if $s eq '$';
push @::LEXVARS, "my List[$type] $var = List[$type].new();\n"
if $s eq '@';
push @::LEXVARS, "my Dictionary[str,$type] $var = Dictionary[str,$type].new();\n" if $s eq '%';
return $var;
}
}
}
{ package VAST::vws; our @ISA = 'VAST::Base';
}
{ package VAST::ws; our @ISA = 'VAST::Base';
}
{ package VAST::xblock; our @ISA = 'VAST::Base';
sub emit_p5 { my $self = shift;
my @t = $self->SUPER::emit_p5;
$t[0] = '(' . $t[0] . ')';
$t[0] =~ s/(\s+)\)$/)$1/;
@t;
}
}
{ package VAST::XXX; our @ISA = 'VAST::Base';
}
{ package REbase;
sub kids { }
sub clone {
my $self = shift;
my $dopp = bless { %$self }, ref($self);
for my $dkid ($dopp->kids) {
$$dkid = $$dkid->clone;
}
$dopp;
}
sub new { my $class = shift;
my $self = bless { a => 0, i => $::IGNORECASE ? 1 : 0,
r => $::RATCHET ? 1 : 0, s => $::SIGSPACE ? 1 : 0,
dba => $::DBA, dic => $::DECL_CLASS, @_ }, $class;
$self;
}
sub optimize { my $self = shift;
for my $kid ($self->kids) {
$$kid = $$kid->optimize;
}
$self;
}
sub clean { my $self = shift;
for my $kid ($self->kids) {
$$kid->clean;
}
delete $self->{r};
delete $self->{s};
delete $self->{a};
delete $self->{i} unless $self->{i_needed};
delete $self->{i_needed};
delete $self->{dba} unless $self->{dba_needed};
delete $self->{dic} unless $self->{dba_needed};
delete $self->{dba_needed};
}
sub walk { my $self = shift;
say STDERR "--> $self" if $OPT_log;
my $exp = $self->_walk;
if ($self->{r} && $exp->maybacktrack) {
$exp = DEEP::cut($exp);
}
say STDERR "<-- $exp: ", $exp->p5expr if $OPT_log;
$exp;
}
sub _walk {
my $self = shift;
my $result = "";
if ($$self{zyg}) {
foreach my $kid (@{$$self{zyg}}) {
my $x = $kid->walk->p5;
$result .= $x if defined $x;
}
}
else {
return ref $self;
}
return DEEP::raw($result);
}
sub bind { my $self = shift; my $re = shift;
return $re unless @_;
DEEP::bind($re, @_);
}
sub remove_leading_ws { } # this tree node not interested
sub has_trailing_ws { 0 }
}
{ package RE_double; use base "REbase";
sub _walk {
my $self = shift;
my $text = $$self{text};
$$self{i_needed} = 1;
# XXX needs interpolation
if ($$self{i}) {
$text = $::REV ? "(?<=" . ::rd($text) . ")" : ::rd($text);
DEEP::raw('$C->_PATTERN(qr/\\G(?i:' . $text . ')/")', precut => 1);
}
else {
DEEP::raw("\$C->_EXACT(\"" . ::rd($text) . "\")", precut => 1);
}
}
}
{ package RE_string; use base "REbase";
sub _walk {
my $self = shift;
$$self{i_needed} = 1;
my $text = ::rd($$self{text});
$text = "(?<=$text)" if $::REV;
$text = "(?i:$text)" if $$self{i};
DEEP::p5regex($text, has_meta => ($::REV || $$self{i}),
needs_bracket => !($::REV || $$self{i}) && (length($$self{text}) != 1));
}
}
{ package RE_sequence;
sub new {
my ($class, @zyg) = @_;
$class->SUPER::new(zyg => \@zyg);
}
sub wrapone {
my ($self, $outer, $inner) = @_;
my ($out1, $outr) = $outer->uncut;
if ($outr) {
DEEP::ratchet($inner, $out1);
} else {
DEEP::raw(::hang("STD::LazyMap::lazymap(" . DEEP::chunk($inner)->p5expr .
",\n" . $outer->p5expr . ")", " "));
}
}
sub _walk {
my $self = shift;
my @result;
my @decl;
if ($$self{zyg}) {
my @kids = @{$$self{zyg}};
my @ckids;
while (@kids and ref $kids[0] eq 'RE_decl') {
push @decl, shift(@kids)->walk->p5block;
}
@kids = map { $_->walk } @kids;
while (@kids) {
my $rx = '';
my $hm = 0;
while (@kids && $kids[0]->isa('DEEP::p5regex')) {
my $rk = shift(@kids);
$rx .= $rk->cutre(0);
$hm ||= $rk->{has_meta};
}
if ($rx ne '') {
push @ckids, DEEP::p5regex($rx, needs_bracket => 1,
has_meta => $hm);
}
if (@kids) {
push @ckids, shift(@kids);
}
}
@ckids = reverse @ckids if $::REV;
@result = @ckids;
}
my $result = pop @result;
for (reverse @result) {
$result = $self->wrapone($_,$result);
}
@decl ?
DEEP::raw(join('', @decl, $result ? $result->p5expr . "\n" : ''), isblock => 1) :
$result // DEEP::raw('', isblock => 1);
}
sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
sub optimize { my $self = shift;
my @ok;
my $afterspace = 0;
for my $kid ($self->kids) {
$$kid->remove_leading_ws if $afterspace;
$afterspace = $$kid->has_trailing_ws($afterspace);
}
$self = $self->SUPER::optimize;
for my $k (@{$self->{zyg}}) {
next if $k->isa('RE_noop');
if ($k->isa('RE_sequence')) {
push @ok, @{$k->{zyg}};
} else {
push @ok, $k;
}
}
return RE_noop->new if @ok == 0;
return $ok[0] if @ok == 1;
$self->{zyg} = \@ok;
$self;
}
sub remove_leading_ws {
my $self = shift;
for my $kid ($self->kids) {
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("Can't 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 "Can't 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);
}
sub _walk {
my $self = shift;
my $result;
local $::PLURALITY = 2;
my $quant = "";
my $rep = "_REP";
my $q = $$self{quant};
my $bind = $::BINDINSIDE;
undef $::BINDINSIDE;
my $atom = $$self{atom}->walk;
if ($bind) { #XXX STD
$atom = $self->bind($atom, $bind);
}
my $atom_is_cut = !$atom->maybacktrack;
my ($qfer,$how,$rest) = @{$$self{quant}};
my $hc = $how eq '!' ? 'g' :
$how eq '?' ? 'f' :
'r';
my $hr = $how eq '!' ? '' :
$how eq '?' ? '?' :
'+';
if ($atom->isa('DEEP::p5regex') && $hc eq 'r' && !$::REV && $qfer ne '**') {
return DEEP::p5regex($atom->cutre(1) . "$qfer$hr", needs_bracket => 1);
}
if ($qfer eq '*') {
$quant = "\$C->_STAR$hc$::REV(";
}
elsif ($qfer eq '+') {
$quant = "\$C->_PLUS$hc$::REV(";
}
elsif ($qfer eq '?') {
$quant = "\$C->_OPT$hc$::REV(";
}
elsif ($qfer eq '**') {
if (ref $rest) {
if (ref $rest eq "RE_block") {
$rep = "_REPINDIRECT$::REV";
$rest = $rest->walk;
}
else {
$rep = "_REPSEP$::REV";
$rest = DEEP::chunk($rest->walk)->p5expr;
}
}
else {
$rest = "'$rest'";
}
$quant = "\$C->$rep$hc( $rest, ";
}
return DEEP::raw($quant . ::hang(DEEP::chunk($atom)->p5expr, " ") . ")", precut => ($hc eq 'r'));
}
sub kids { my $self = shift; \$self->{atom} }
sub optimize {
my $self = shift()->SUPER::optimize;
if ($self->{quant}[0] eq '*' &&
$self->{quant}[1] ne ':' &&
$self->{atom}->isa('RE_meta') &&
$self->{atom}{text} eq '.') {
delete $self->{atom};
$self->{text} = ($self->{quant}[1] eq '?') ? '.*?' : '.*';
delete $self->{quant};
bless $self, 'RE_meta';
}
$self;
}
}
{ package RE_qw; use base "REbase";
sub _walk {
my $self = shift;
DEEP::raw("\$C->_ARRAY$::REV( qw$$self{text} )");
}
}
{ package RE_method_re; use base "REbase";
sub _walk {
my $self = shift;
my $re = $$self{re};
my $name = $$self{name};
die("Can't reverse $name") if $::REV and $name ne 'before';
local $::REV = $name eq 'after' ? '_rev' : '';
{
local %::BINDINGS;
$re = $re->walk->p5block;
if (%::BINDINGS) {
for my $binding ( keys %::BINDINGS ) {
next unless $::BINDINGS{$binding} > 1;
$re = <<"END" . $re;
\$C->{'$binding'} = [];
END
}
}
}
$::REV = '';
$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') {
if ($::REV) {
return DEEP::p5regex($not ? '(?<=[^\x20\t\r])' : '(?<=[\x20\t\r])');
}
else {
return DEEP::p5regex($not ? '[^\x20\t\r]' : '[\x20\t\r]');
}
}
elsif ($text eq '\\v') {
if ($::REV) {
return DEEP::p5regex($not ? '(?<=[^\n])' : '(?<=[\n])');
}
else {
return DEEP::p5regex($not ? '[^\n]' : '\n');
}
}
elsif ($text eq '»') {
return DEEP::p5regex('\b');
}
elsif ($text eq '«') {
return DEEP::p5regex('\b');
}
elsif ($text eq '>>') {
$code = "\$C->_RIGHTWB$::REV()";
}
elsif ($text eq '<<') {
$code = "\$C->_LEFTWB$::REV()";
}
elsif ($text eq '<(') {
$code = "\$C->_LEFTRESULT$::REV()";
}
elsif ($text eq ')>') {
$code = "\$C->_RIGHTRESULT$::REV()";
}
elsif ($text eq '<~~>') {
$code = "\$C->$::NAME()";
$bt = 1;
}
else {
$code = "\$C->_EXACT$::REV(\"$text\")";
}
if ($not) { # XXX or maybe just .NOT on the end...
$code = "\$C->_NOTCHAR( sub { my \$C=shift;\n" . ::indent($code) . "\n})";
}
DEEP::raw($code, precut => !$bt);
}
}
{ package RE_cclass; use base "REbase";
sub _walk {
my $self = shift;
my $text = $$self{text};
$self->{i_needed} = 1;
$text =~ s!(\/|\\\/)!\\$1!g;
$text =~ s/\s//g;
$text =~ s/\.\./-/g;
$text =~ s/^-\[/[^/;
$text = "(?<=$text)" if $::REV;
if ($$self{i}) {
DEEP::p5regex("(?i:$text)");
}
else {
DEEP::p5regex($text, needs_bracket => 1);
}
}
}
{ package RE_noop; use base "REbase";
sub _walk {
my $self = shift;
DEEP::raw('$C', precut => 1);
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$before;
}
}
{ package RE_decl; use base "REbase";
# because cutting one of these would be a disaster
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->{r} = 0;
$self;
}
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{body};
}
sub _walk {
my $self = shift;
DEEP::raw($$self{body}, isblock => 1);
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$before;
}
}
{ package RE_block; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{context};
delete $self->{body};
}
sub _walk {
my $self = shift;
my $ctx = $$self{context};
my $text = ::indent($$self{body});
if ($ctx eq 'void') {
return DEEP::raw("scalar(do {\n" . ::indent($text) . "}, \$C)", precut => 1);
}
elsif ($ctx eq 'bool') {
return DEEP::raw("((\$C) x !!do {\n" . ::indent($text) . "})", precut => 1);
}
else {
return DEEP::raw("sub {\n" . ::indent("my \$C=shift;\n" . $text) . "}", precut => 1);
}
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$before;
}
}
{ package RE_bracket; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{decl};
}
sub _walk {
my $self = shift;
my ($re, $r) = $$self{re}->walk->uncut;
my @decl = map { $_->walk } @{$$self{decl}};
DEEP::raw("\$C->_BRACKET$r(" . ::hang(DEEP::chunk($re, @decl)->p5expr, " ") . ")");
}
sub kids { my $self = shift; \$self->{re} }
sub remove_leading_ws {
my $self = shift;
my $re = $$self{re};
$re->remove_leading_ws();
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$$self{re}->has_trailing_ws($before);
}
}
{ package RE_var; use base "REbase";
sub _walk {
my $self = shift;
my $var = $$self{var};
if ($var =~ /^\$/) {
if ($var =~ /^\$M->{(.*)}/) {
my $p = (substr($1,0,1) eq "'") ? "n" : "p";
DEEP::raw("\$C->_BACKREF$p$::REV($1)");
}
else {
DEEP::raw("\$C->_EXACT$::REV($var)");
}
}
elsif ($var =~ /^\@/) {
DEEP::raw("\$C->_ARRAY$::REV($var)");
}
elsif ($var =~ /^\%/) {
DEEP::raw("\$C->_HASH$::REV($var)");
}
}
}
{ package RE_paren; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{decl};
}
sub _walk {
my $self = shift;
my $re;
{
local %::BINDINGS;
$re = $$self{re}->walk->p5block;
if (%::BINDINGS) {
for my $binding ( keys %::BINDINGS ) {
next unless $::BINDINGS{$binding} > 1;
my $re = <<"END" . $re;
\$C->{'$binding'} = [];
END
}
}
}
$re = "\$C->_$::REV"."PAREN( " . ::hang(DEEP::chunk(DEEP::raw($re))->p5expr, " ") . ")";
DEEP::raw($re);
}
sub kids { my $self = shift; \$self->{re} }
# yes, () would capture the ws, but we're guaranteed to be past it already
sub remove_leading_ws {
my $self = shift;
my $re = $$self{re};
$re->remove_leading_ws();
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$$self{re}->has_trailing_ws($before);
}
}
{ package RE_bindpos; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{var};
}
sub _walk {
my $self = shift;
my $var = $$self{var};
$::BINDINGS{$var} += $::PLURALITY;
my $re = $$self{atom}->walk;
$self->bind($re, $var);
}
sub kids { my $self = shift; \$self->{atom} }
sub remove_leading_ws {
my $self = shift;
my $re = $$self{atom};
$re->remove_leading_ws();
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$$self{atom}->has_trailing_ws($before);
}
}
{ package RE_bindnamed; use base "REbase";
sub clean { my $self = shift;
$self->SUPER::clean;
delete $self->{var};
}
sub _walk {
my $self = shift;
my $var = $$self{var};
# XXX STD for gimme5 bug-compatibility, names push inside quantifiers
$::BINDINGS{$var} += $::PLURALITY;
if ($$self{atom}->isa('RE_quantified_atom')) {
local $::BINDINSIDE = $var;
return $$self{atom}->walk;
}
my $re = $$self{atom}->walk;
$self->bind($re, $var);
}
sub kids { my $self = shift; \$self->{atom} }
sub remove_leading_ws {
my $self = shift;
my $re = $$self{atom};
$re->remove_leading_ws();
}
sub has_trailing_ws {
my $self = shift;
my $before = shift;
$$self{atom}->has_trailing_ws($before);
}
}
# DEEP is the lowest level of desugaring used by viv, but it still keeps a tree
# structure. Not all DEEP nodes are interchangable; some represent expression
# bits, others statements with no sensible return value.
{ package DEEPbase;
}
{ package DEEPexpr;
sub maybacktrack { 1 }
sub uncut { my $self = shift; $self, ($self->maybacktrack ? '' : 'r') }
# p5 should return (is a block?), text; takes arguments sh (can shadow $C?)
# and ov (can overwrite $C?); non-block returns may not shadow
sub p5expr { my $self = shift;
my ($isbl, $text) = $self->p5(@_, sh => 1);
$isbl ? ("do {\n" . ::indent($text) . "\n}") : $text;
}
sub p5block { my $self = shift;
my ($isbl, $text) = $self->p5(@_);
$isbl ? $text : ($text . "\n");
}
# psq returns the same as p5 for now
sub psqexpr { my $self = shift;
my ($isbl, $text) = $self->psq(@_, sh => 1);
$isbl ? ("do {\n" . ::indent($text) . "\n}") : $text;
}
}
{ package DEEP::raw; our @ISA = 'DEEPexpr';
sub DEEP::raw {
my $text = shift;
bless { text => $text, @_ }, "DEEP::raw";
}
sub maybacktrack {
my $self = shift;
return !$self->{precut};
}
sub p5 { my $self = shift;
$self->{isblock}, $self->{text};
}
sub psq { my $self = shift;
$self->{isblock}, $self->{text};
}
}
{ package DEEP::cut; our @ISA = 'DEEPexpr';
sub DEEP::cut {
my $child = shift;
if (!$child->maybacktrack) {
return $child;
}
if ($child->isa('DEEP::bind')) {
return DEEP::bind(DEEP::cut($child->{child}), @{$child->{names}});
}
bless { child => $child }, "DEEP::cut";
}
sub p5 { my $self = shift;
1, "if (my (\$C) = (" . ::hang($self->{child}->p5expr, " ") . ")) { (\$C) } else { () }\n";
}
sub maybacktrack { 0 }
sub uncut {
my $self = shift;
my ($child_uncut) = $self->{child}->uncut;
$child_uncut, 'r';
}
}
{ package DEEP::bind; our @ISA = 'DEEPexpr';
sub DEEP::bind {
my $child = shift;
my @names = @_;
if ($child->isa('DEEP::bind')) {
push @names, @{$child->{names}};
$child = $child->{child};
}
bless { child => $child, names => \@names }, "DEEP::bind";
}
sub maybacktrack { $_[0]{child}->maybacktrack }
sub p5 { my $self = shift;
my ($chinner, $r) = $self->{child}->uncut;
0, "\$C->_SUBSUME$r([" .
join(',', map {"'$_'"} @{$self->{names}}) .
"], sub {\n" . ::indent("my \$C = shift;\n" .
$chinner->p5block(cl => 1, sh => 1)) . "})";
}
}
{ package DEEP::ratchet; our @ISA = 'DEEPexpr';
sub DEEP::ratchet {
my $child = shift;
my @before = @_;
if (::DARE_TO_OPTIMIZE) {
if ($child->isa('DEEP::ratchet')) {
push @before, @{$child->{before}};
$child = $child->{child};
}
my ($chinner, $chr) = $child->uncut;
if ($chr && $chinner != $child) {
push @before, $chinner;
$child = DEEP::raw('$C', precut => 1);
}
}
bless { child => $child, before => \@before }, "DEEP::ratchet";
}
sub maybacktrack { $_[0]{child}->maybacktrack }
sub p5 { my $self = shift; my %a = @_;
if (@{$self->{before}} == 1) {
my $pre = $self->{before}[0];
return 1, "if (my (\$C) = (" . ::hang($pre->p5expr, " " x 8). ")) {\n" .
::indent($self->{child}->p5block) . "} else { () }\n";
}
my $conditional = join ::hang("\nand ", " "),
map { "(\$C) = (" . ::hang($_->p5expr, " " x 8) . ")" }
@{$self->{before}};
my $guts = ($conditional ?
"if ($conditional) {\n" .
::indent($self->{child}->p5block) . "} else { () }\n"
: $self->{child}->p5block(cl => 1, sh => 1));
$guts = "my \$C = \$C;\n" . $guts unless $a{cl};
$guts = "do {\n" . ::indent($guts) . "};\n" unless $a{sh};
1, $guts;
}
}
# NOT a regex bit, but a value
{ package DEEP::chunk; our @ISA = 'DEEPexpr';
sub DEEP::chunk {
my $child = shift;
bless { child => $child, decl => \@_ }, "DEEP::chunk";
}
sub p5 {
my $self = shift;
0, "sub {\n" . ::indent(
"my \$C=shift;\n" .
join("", map { $_->p5block } @{ $self->{decl} }) .
$self->{child}->p5block(cl => 1, sh => 1)) . "}";
}
}
{ package DEEP::p5regex; our @ISA = 'DEEPexpr';
sub DEEP::p5regex {
my $text = shift;
bless { text => $text, has_meta => 1, @_ }, "DEEP::p5regex";
}
sub p5 {
my $self = shift;
0, $self->{has_meta} ?
"\$C->_PATTERN(qr/\\G" . $self->{text} . "/)" :
"\$C->_EXACT(\"" . $self->{text} . "\")";
}
sub cutre {
my $self = shift;
my $btoo = shift;
$self->{needs_cut} ? "(?>" . $self->{text} . ")"
: ($btoo && $self->{needs_bracket}
? "(?:" . $self->{text} . ")"
: $self->{text});
}
sub maybacktrack { 0 }
}
{ package DEEP::call; our @ISA = 'DEEPexpr';
sub DEEP::call {
my ($name, @args) = @_;
bless { name => $name, args => \@args }, "DEEP::call";
}
my %psq_map = (
'note', => "System.Console.Error.WriteLine"
);
sub psq { my $self = shift;
my $n = $self->{name};
my $np = $psq_map{$n};
if (!ref $np) {
my $n2 = $psq_map{$n} // $n;
if ($n2 =~ /infix:<(.*)>/) {
my $op = " $1 ";
$np = sub { my ($a1, $a2) = @_;
"(" . $a1->psqexpr . $op . $a2->psqexpr . ")"; };
}
elsif ($n2 =~ /prefix:<(.*)>/) {
my $op = $1;
$np = sub { my ($a) = @_;
"(" . $op . $a->psqexpr . ")"; };
}
elsif ($n2 =~ /postfix:<(.*)>/) {
my $op = $1;
$np = sub { my ($a) = @_;
"(" . $a->psqexpr . $op . ")"; };
}
else {
$np = sub { $n2 . "(" . join(", ",
map { $_->psqexpr } @_) . ")" };
}
$psq_map{$n} = $np;
}
return 0, $np->(@{$self->{args}});
}
}
if ($0 eq __FILE__) {
::MAIN(@ARGV);
}
1;
# vim: ts=8 sw=4 noexpandtab smarttab