src/perl6/viv

   1 #!/usr/bin/env perl
   2
   3 =head1 NAME
   4
   5 viv - The STD.pm6 command line multitool
   6
   7 =head1 SYNOPSIS
   8
   9 viv [options] [file...]
  10
  11  -e --evaluate TEXT          Use code from the command line
  12     --thaw                   Input is a --freeze dump, not Perl 6
  13  -o --output FILE            Send result to FILE, not stdout
  14     --noperl6lib             Disable use of the PERL6LIB variable
  15     --symlroot DIR           Use DIR as parsed module cache
  16     --concise                Pretty-print the parse tree (default)
  17  -c --check                  Just check syntax
  18     --freeze                 Generate Storable dump of parse tree
  19  -y --yaml                   Generate YAML parse tree
  20  -5 --p5                     Translate to Perl 5 syntax
  21  -6 --p6                     Translate back to Perl 6
  22     --psq                    Translate to Perlesque syntax
  23  -s --stab                   Include symbol table in output
  24  -m --match                  Include match tree in output
  25     --no-indent              Disable indentation of output
  26  -l --log                    Be verbose while generating output
  27  -k --keep-going             Don't stop if error found during output phase
  28     --compile-setting FILE   Preparse a CORE.setting file
  29     --help                   This message
  30
  31 =cut
  32
  33 use strict;
  34 use 5.010;
  35 use warnings FATAL => 'all';
  36
  37 use List::Util qw/sum min/;
  38
  39 use utf8;
  40 use YAML::XS; # An attempt to replace this with YAML::Syck passed the
  41               # tests but produced a different output format that
  42               # confused some calling programs.  For example, anchors
  43               # are usually numbers ascending from 1, and they became
  44               # disjoint sets of descending numbers.  Also, empty
  45               # sequences shown as [] became followed by an empty line.
  46               # See also: YAML::Syck in package VAST::package_def below.
  47 use Encode;
  48 use Scalar::Util 'blessed', 'refaddr';
  49 use Storable;
  50 use Try::Tiny;
  51
  52 our $OPT_match = 0;
  53 our $OPT_log = 0;
  54 our $OPT_stab = 0;
  55 our $OPT_thaw = 0;
  56 our $OPT_keep_going = 0;
  57 our $OPT_compile_setting = 0;
  58 our $OPT_output_file = undef;
  59 my $PROG = '';
  60 our $ORIG;
  61 my $U = 0;
  62 my @did_ws;
  63
  64 my @context;
  65 $::MULTINESS = '';
  66 # XXX STD Global trait tables simulate inheritence
  67 local $::PROTO = {};
  68 local $::PROTOSIG = {};
  69
  70 BEGIN {
  71     # Let's say you have a tricky optimization that breaks the build.  You want
  72     # to know exactly which rewrite is culpable?  Try bisecting with
  73     # VIV_OPTLIMIT, after wrapping the rewrite in if (DARE_TO_OPTIMIZE).
  74     my $optlimit = $ENV{VIV_OPTLIMIT};
  75     if (defined $optlimit) {
  76         *DARE_TO_OPTIMIZE = Sub::Name::subname(DARE_TO_OPTIMIZE => sub {
  77                 $optlimit-- > 0
  78         });
  79     } else {
  80         constant->import(DARE_TO_OPTIMIZE => 1);
  81     }
  82 }
  83
  84 our $OPT_output = 'concise';
  85
  86 use FindBin;
  87 use File::Spec;
  88 use Getopt::Long 2.34 'HelpMessage';
  89
  90 my ($boot, $symlroot);
  91 {
  92     no warnings;
  93     $CursorBase::NOPERL6LIB;
  94 }
  95
  96 my $r = GetOptions(
  97     "evaluate|e=s" => sub { $PROG .= Encode::decode_utf8($_[1]) . "\n" },
  98     "boot"         => \$boot,
  99     "noperl6lib"   => \$CursorBase::NOPERL6LIB,
 100     "symlroot"     => \$symlroot,
 101     "concise"      => sub { $OPT_output = 'concise' },
 102     "yaml|y"       => sub { $OPT_output = 'yaml' },
 103     "output|o=s"   => \$OPT_output_file,
 104     "p5|5"         => sub { $OPT_output = 'p5' },
 105     "p6|6"         => sub { $OPT_output = 'p6' },
 106     "psq"          => sub { $OPT_output = 'psq' },
 107     "freeze"       => sub { $OPT_output = 'store' },
 108     "check|c"      => sub { $OPT_output = 'none' },
 109     "stab|s"       => \$OPT_stab,
 110     "log|l"        => \$OPT_log,
 111     "pos|p"        => sub { },
 112     "no-indent"    => sub {
 113         no warnings 'redefine';
 114         *indent = \&no_indent;
 115         *hang = \&no_indent;
 116     },
 117     "match|m"      => \$OPT_match,
 118     "thaw"         => \$OPT_thaw,
 119     "keep-going|k" => \$OPT_keep_going,
 120     "compile-setting=s" => \$OPT_compile_setting,
 121     "help"         => sub { HelpMessage() }
 122 );
 123
 124 unshift @INC, $FindBin::Bin;
 125 if ($boot) {
 126     no warnings 'once';
 127     unshift @INC, File::Spec->catdir($FindBin::Bin, "boot");
 128     $CursorBase::SET_STD5PREFIX = "boot";
 129     $CursorBase::NOSTDSYML = 1;
 130 }
 131 if (defined $symlroot) {
 132     $CursorBase::SET_STD5PREFIX = $symlroot;
 133 }
 134
 135 require Actions;
 136 require STD;
 137
 138 sub spew {
 139     my $bits = shift;
 140     $bits .= "\n" unless $bits ~~ /\n\z/;
 141     if (defined $OPT_output_file) {
 142         open my $out, ">", $OPT_output_file
 143             or die "cannot open $OPT_output_file for writing: $!";
 144         binmode $out, ":utf8";
 145         print $out $bits or die "cannot write: $!";
 146         close $out or die "cannot close: $!";
 147     } else {
 148         print $bits;
 149     }
 150 }
 151
 152 sub no_indent { $_[0] }
 153
 154 sub hang {
 155     my ($arg, $leader) = @_;
 156
 157     $arg =~ s/\n/\n$leader/g;
 158
 159     return $arg;
 160 }
 161
 162 sub listify {
 163     my $r = "";
 164     for my $i (0 .. $#_) {
 165         $r .= ($i == $#_) ? "\n└─" : "\n├─";
 166         $r .= hang($_[$i], $i == $#_ ? "  " : "│ ");
 167     }
 168     $r;
 169 }
 170
 171 sub shred {
 172     my ($first, $rest, $tx) = @_;
 173     my $out = "";
 174
 175     while (length $tx > $first) {
 176         $out .= substr($tx, 0, $first);
 177         $out .= "\n";
 178         $tx = substr($tx, $first);
 179         $first = $rest;
 180     }
 181
 182     $out . $tx;
 183 }
 184
 185 sub concise {
 186     my ($node, $width) = @_;
 187
 188     $width = 30 if $width < 30;
 189
 190     if (!ref $node) {
 191         return defined($node) ? shred($width, $width, "$node") : "undef";
 192     } elsif (blessed($node) && ref($node) =~ /^VAST/) {
 193         my @pos =
 194             ref($node->{"."}) eq 'ARRAY' ? @{$node->{"."}} :
 195             defined($node->{"."})        ? $node->{"."}    :
 196             ();
 197         my %nam = %$node;
 198
 199         delete $nam{"."};
 200
 201         # don't list the same node twice
 202         my %inpos = map { ref($_) ? (refaddr($_) , 1) : () } @pos;
 203
 204         @pos = map { concise($_, $width-2) } @pos;
 205
 206         my @oobnam;
 207         my $title = blessed $node;
 208         my $x = length($title);
 209         for my $ch (sort keys %nam) {
 210             next if $ch eq '_fate';
 211             if (ref $nam{$ch}) {
 212                 # hide named children that are just (lists of) positional children
 213                 if ($inpos{refaddr($nam{$ch})}) { next }
 214                 if (ref($nam{$ch}) eq 'ARRAY') {
 215                     my $all = 1;
 216                     for (@{$nam{$ch}}) { $all = 0 unless ref $_ && $inpos{refaddr $_} }
 217                     next if $all;
 218                 }
 219             }
 220
 221             my $repr = concise($nam{$ch}, $width-4);
 222
 223             if ($repr !~ /\n/ && length $repr < 30) {
 224                 if ($x + length($ch) + length($repr) + 6 > $width) {
 225                     $title .= ",\n";
 226                     $x = 4;
 227                 } else {
 228                     $title .= ", ";
 229                     $x += 2;
 230                 }
 231                 $title .= "$ch: $repr";
 232                 $x += length("$ch: $repr");
 233             } else {
 234                 my $hang = " " x (length($ch)+2);
 235                 push @oobnam, "$ch: " . hang($repr, $hang);
 236             }
 237         }
 238
 239         $title = hang($title, (@pos ? "│ " : "  ") . (@oobnam ? "│ " : "  "));
 240
 241         my $result = $title;
 242
 243         $result .= hang(listify(@oobnam), @pos ? "│ " : "  ");
 244         $result .= listify(@pos);
 245
 246         return $result;
 247     } else {
 248         my $d = Dump($node);
 249         return substr($d, 4, length($d)-5);
 250     }
 251 }
 252
 253 # viv should likely be abstracted into a module instead of doing this hack... - pmurias
 254 sub VIV::SET_OPT {
 255     my %opt = @_;
 256     $OPT_match = $opt{match};
 257     $OPT_log = $opt{log};
 258 }
 259
 260 sub fixpod {
 261     my $text = shift;
 262     return $text unless $text =~ /\n/;
 263     my @text = split(/^/, $text);
 264     my $in_begin = 0;
 265     my $in_for = 0;
 266     for (@text) {
 267         $in_begin = $1 if /^=begin\s+(\w+)/;
 268         $in_for = 1 if /^=for/;
 269         $in_for = 0 if /^\s*$/;
 270         my $docomment = $in_begin || $in_for;
 271         $in_begin = 0 if /^=end\s+(\w+)/ and $1 eq $in_begin;
 272         s/^/# / if $docomment;
 273     }
 274     join('', @text);
 275 }
 276
 277 # rules of thumb: a block (0 or more statements) is a chunk of text, use
 278 # indent.  for expressions, the overall philosophy is that the indentation
 279 # of a line should be proportional to the number of outstanding syntactic
 280 # groups
 281 sub indent {
 282     my $x = shift || '';
 283     my $i = shift || 1;
 284     my $s = '    ' x $i;
 285     $x =~ s/^/$s/mg;
 286     $x;
 287 }
 288
 289 sub unsingle {
 290     my $in = $_[0];
 291     my $out = '';
 292     while ($in ne '') {
 293         $out .= $1 if $in =~ s/^\\([\\'])//;
 294         $out .= $1 if $in =~ s/^(.)//;
 295     }
 296     $out;
 297 }
 298
 299 # XXX this is only used for backslash escapes in regexes
 300 sub undouble {
 301     my $in = $_[0];
 302     my $out = '';
 303     my %trans = ( 'n' => "\n" );
 304     while ($in ne '') {
 305         $out .= $trans{$1} // $1 if $in =~ s/^\\(.)//;
 306         $out .= $1 if $in =~ s/^(.)//;
 307     }
 308     $out;
 309 }
 310
 311 sub rd {
 312     my $in = shift;
 313     my $out = '';
 314     for my $ch (split //, $in) {
 315         $out .= $ch eq "\n" ? '\n' : quotemeta($ch);
 316     }
 317     $out;
 318 }
 319
 320 ###################################################################
 321
 322 { package VAST::Base;
 323
 324     sub Str { my $self = shift;
 325         my $b = $self->{BEG};
 326         my $e = $self->{END};
 327         return '' if $b > length($ORIG);
 328         substr($ORIG, $b, $e - $b);
 329     }
 330
 331     sub kids { my $self = shift;
 332         my $key = shift() // '.';
 333         return () unless exists $self->{$key};
 334         my $entry = $self->{$key};
 335         return ref($entry) eq 'ARRAY' ? @$entry : $entry;
 336     }
 337
 338     sub emit_p6 { my $self = shift;
 339         my @text;
 340         if (exists $self->{'.'}) {
 341             my $last = $self->{BEG};
 342             my $all = $self->{'.'};
 343             my @kids;
 344             for my $kid (ref($all) eq 'ARRAY' ? @$all : $all) {
 345                 next unless $kid;
 346                 if (not defined $kid->{BEG}) {
 347                     $kid->{BEG} = $kid->{_from} // next;
 348                     $kid->{END} = $kid->{_pos};
 349                 }
 350                 push @kids, $kid;
 351             }
 352             for my $kid (sort { $a->{BEG} <=> $b->{BEG} } @kids) {
 353                 my $kb = $kid->{BEG};
 354                 if ($kb > $last) {
 355                     push @text, substr($ORIG, $last, $kb - $last);
 356                 }
 357                 if (ref($kid) eq 'HASH') {
 358                     print STDERR ::Dump($self);
 359                     die "in a weird place";
 360                 }
 361                 push @text, scalar $kid->p6;
 362                 $last = $kid->{END};
 363
 364             }
 365             my $se = $self->{END};
 366             if ($se > $last) {
 367                     push @text, substr($ORIG, $last, $se - $last);
 368             }
 369         }
 370         else {
 371             # print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
 372             push @text, $self->{TEXT};
 373         }
 374         wantarray ? @text : join('', @text);
 375     }
 376
 377     sub emit_p5 { my $self = shift;
 378         my @text;
 379         if (exists $self->{'.'}) {
 380             my $last = $self->{BEG};
 381             my $all = $self->{'.'};
 382             my @kids;
 383             for my $kid (ref($all) eq 'ARRAY' ? @$all : $all) {
 384                 next unless $kid;
 385                 if (not defined $kid->{BEG}) {
 386                     $kid->{BEG} = $kid->{_from} // next;
 387                     $kid->{END} = $kid->{_pos};
 388                 }
 389                 push @kids, $kid;
 390             }
 391             for my $kid (sort { $a->{BEG} <=> $b->{BEG} } @kids) {
 392                 my $kb = $kid->{BEG};
 393                 if ($kb > $last) {
 394                     push @text, substr($ORIG, $last, $kb - $last);
 395                 }
 396                 if (ref($kid) eq 'HASH') {
 397                     print STDERR ::Dump($self);
 398                     die "in a weird place";
 399                 }
 400                 push @text, scalar $kid->p5;
 401                 $last = $kid->{END};
 402
 403             }
 404             my $se = $self->{END};
 405             if ($se > $last) {
 406                     push @text, substr($ORIG, $last, $se - $last);
 407             }
 408         }
 409         else {
 410             # print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
 411             push @text, $self->{TEXT};
 412         }
 413         wantarray ? @text : join('', @text);
 414     }
 415
 416     BEGIN {
 417         my $tpl = <<'TEMPLATE';
 418     sub VAST::Base::FORM { my $self = shift; my $lvl = @context;
 419         my @text;
 420         say STDERR ' ' x $lvl, ref $self, " from ",$self->{BEG}," to ",$self->{END} if $OPT_log;
 421         $context[$lvl] = $self;
 422         # print STDERR "HERE " . ref($self) . "\n";
 423         local $SIG{__DIE__} = sub {
 424             my @args = @_;
 425             $args[-1] =~ s/ at .*? line .*?\n$//s if $args[-1] =~ /\n$/s;
 426             die Carp::longmess(@args);
 427         };
 428         my @bits = !$OPT_keep_going ? $self->emit_FORM(@_) : (::try {
 429             $self->emit_FORM(@_);
 430         } ::catch {
 431             my $char = $self->{BEG} // $self->{_from} // 0;
 432             my $line = 1 + (substr($ORIG, 0, $char) =~ y/\n/\n/);
 433             say STDERR "!!! FAILED at $char (L$line)";
 434             print STDERR $_;
 435             "<<< ERROR >>>";
 436         });
 437         my $val = join '', @bits;
 438         my @c = map { ref $_ } @context;
 439         my $c = "@c";
 440         $c =~ s/VAST:://g;
 441         say STDERR ' ' x ($lvl-1), "$c returns $val\n" if $OPT_log;
 442         # Note that we may have skipped levels, so you can't just pop
 443         splice(@context,$lvl);
 444         wantarray ? @bits : $val;
 445     }
 446 TEMPLATE
 447         for my $format (qw/p5 p6 psq/) {
 448             my $t = $tpl;
 449             $t =~ s/FORM/$format/g;
 450             eval $t;
 451         }
 452     }
 453
 454     sub gap { my $self = shift;
 455         my $after = shift;
 456         my $beg = $self->{END};
 457         my $end = $after->{BEG};
 458         return '' unless $beg && $end;
 459         return substr($ORIG, $beg, $end - $beg);
 460     }
 461
 462     sub base_re_quantifier { my $self = shift; my $x = shift; my $min = shift;
 463         my $qm = $self->{quantmod}->Str;
 464         $qm =~ s/:(.)/$1/;
 465         $qm ||= $::RATCHET ? ':' : '!';
 466         $qm =~ s/\+/!/;
 467         return [ $self->{SYM}, $qm, $x, $min ];
 468     }
 469 }
 470
 471 { package VAST::ViaDEEP;
 472     sub emit_psq {  my $self = shift;
 473         $self->_deep->psqexpr;
 474     }
 475 }
 476
 477 { package VAST::InfixCall;
 478     sub emit_psq {  my $self = shift;
 479         return DEEP::call("infix:<" . $self->{infix}{SYM} . ">",
 480             map { DEEP::raw($_->psq) } $self->kids('args'))->psqexpr;
 481     }
 482 }
 483
 484 { package VAST::Str; our @ISA = 'VAST::Base';
 485     sub emit_p5 {  my $self = shift;
 486         return $self->{TEXT};
 487     }
 488     sub emit_p6 {  my $self = shift;
 489         return $self->{TEXT};
 490     }
 491 }
 492
 493 { package VAST::Additive; our @ISA = ('VAST::Base', 'VAST::InfixCall');
 494     sub emit_p5 {  my $self = shift;
 495         my @t = $self->SUPER::emit_p5;
 496         if ($t[0] eq '*') {     # *-1
 497             $t[0] = '';
 498         }
 499         @t;
 500     }
 501 }
 502
 503 { package VAST::Adverb; our @ISA = 'VAST::Base';
 504     sub emit_p5 {  my $self = shift;
 505         my @t = $self->SUPER::emit_p5;
 506         my $adv = pop @t;
 507         if ($adv eq ':delete' or $adv eq ':exists') {
 508             $adv =~ s/^://;
 509             unshift(@t, $adv . ' ');
 510             $t[-1] =~ s/\s+$//;
 511         }
 512         @t;
 513     }
 514 }
 515
 516 { package VAST::apostrophe; our @ISA = 'VAST::Base';
 517 }
 518
 519
 520 { package VAST::arglist; our @ISA = 'VAST::Base';
 521 }
 522
 523
 524 { package VAST::args; our @ISA = 'VAST::Base';
 525     sub deepn { my $self = shift;
 526         my $al = $self->{arglist}[0] // $self->{semiarglist}{arglist}[0];
 527         return unless $al;
 528         $al = $al->{EXPR} or return;
 529
 530         if ($al->isa('VAST::infix__S_Comma')) {
 531             return map { DEEP::raw($_->psq) } $al->kids('args');
 532         } else {
 533             return DEEP::raw($al->psq);
 534         }
 535     }
 536 }
 537
 538
 539 { package VAST::assertion; our @ISA = 'VAST::Base';
 540 }
 541
 542
 543 { package VAST::assertion__S_Bang; our @ISA = 'VAST::Base';
 544     sub re_ast {  my $self = shift;
 545         my $ast = $self->{assertion} ? $self->{assertion}->re_ast
 546             : RE_noop->new;
 547         $ast->{nobind} = 1;
 548         RE_assertion->new(assert => '!', re => $ast);
 549     }
 550 }
 551
 552
 553 { package VAST::assertion__S_Bra; our @ISA = 'VAST::Base';
 554     sub re_ast { my $self = shift;
 555         my $cclass = $self->Str;
 556         $cclass =~ s/\\x([0-9a-fA-F]{3,4})/\\x\{$1\}/g;
 557         RE_cclass->new(text => $cclass);
 558     }
 559 }
 560
 561 { package VAST::assertion__S_Minus; our @ISA = 'VAST::assertion__S_Bra';
 562 }
 563
 564 { package VAST::assertion__S_Plus; our @ISA = 'VAST::assertion__S_Bra';
 565 }
 566
 567
 568 { package VAST::assertion__S_Cur_Ly; our @ISA = 'VAST::Base';
 569     sub re_ast { my $self = shift;
 570         local $::NEEDMATCH = 0;
 571         my $text = $self->{embeddedblock}{statementlist}->p5;
 572         $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
 573         RE_block->new(body => $text, context => 'bool');
 574     }
 575 }
 576
 577
 578 { package VAST::assertion__S_DotDotDot; our @ISA = 'VAST::Base';
 579 }
 580
 581
 582 { package VAST::assertion__S_method; our @ISA = 'VAST::Base';
 583     sub re_ast {  my $self = shift;
 584         my $ast = $self->{assertion}->re_ast;
 585         $ast->{nobind} = 1;
 586         $ast;
 587     }
 588 }
 589
 590
 591 { package VAST::assertion__S_name; our @ISA = 'VAST::Base';
 592     sub re_ast {  my $self = shift;
 593         my $name = $self->{longname}->Str;
 594
 595         if ($self->{nibbler}[0]) {
 596             local $::DBA = $::DBA;
 597             local $::RATCHET = $::RATCHET;
 598             local $::SIGSPACE = $::SIGSPACE;
 599             local $::IGNORECASE = $::IGNORECASE;
 600             return RE_method_re->new(name => $name,
 601                 re => $self->{nibbler}[0]{"."}->re_ast);
 602         }
 603
 604         if ($self->{assertion}[0]) {
 605             return RE_bindnamed->new(var => $name,
 606                 atom => $self->{assertion}[0]->re_ast);
 607         }
 608
 609         if ($name eq 'sym' && defined $::ENDSYM) {
 610             return RE_sequence->new(
 611                 RE_method->new(name => $name, sym => $::SYM),
 612                 RE_method->new(name => $::ENDSYM, nobind => 1));
 613         }
 614
 615         my $al = $self->{arglist}[0];
 616         local $::NEEDMATCH = 0;
 617         $al = defined $al ? "(" . $al->p5 . ")" : undef;
 618         RE_method->new(name => $name, ($name eq 'sym' ? (sym => $::SYM) : ()),
 619             rest => $al, need_match => $::NEEDMATCH);
 620     }
 621 }
 622
 623
 624 { package VAST::assertion__S_Question; our @ISA = 'VAST::Base';
 625     sub re_ast {  my $self = shift;
 626         my $ast = $self->{assertion} ? $self->{assertion}->re_ast
 627             : RE_noop->new;
 628         $ast->{nobind} = 1;
 629         RE_assertion->new(assert => '?', re => $ast);
 630     }
 631 }
 632
 633
 634 { package VAST::atom; our @ISA = 'VAST::Base';
 635     sub re_ast {  my $self = shift;
 636         if (exists $self->{TEXT}) {
 637             RE_string->new(text => $self->{TEXT});
 638         } else {
 639             $self->{metachar}->re_ast;
 640         }
 641     }
 642 }
 643
 644
 645 { package VAST::Autoincrement; our @ISA = 'VAST::Base';
 646 }
 647
 648
 649 { package VAST::babble; our @ISA = 'VAST::Base';
 650 }
 651
 652
 653 { package VAST::backslash; our @ISA = 'VAST::Base';
 654 }
 655
 656
 657 { package VAST::backslash__S_Back; our @ISA = 'VAST::Base';
 658 }
 659
 660
 661 { package VAST::backslash__S_d; our @ISA = 'VAST::Base';
 662 }
 663
 664
 665 { package VAST::backslash__S_h; our @ISA = 'VAST::Base';
 666 }
 667
 668
 669 { package VAST::backslash__S_misc; our @ISA = 'VAST::Base';
 670 }
 671
 672
 673 { package VAST::backslash__S_n; our @ISA = 'VAST::Base';
 674 }
 675
 676
 677 { package VAST::backslash__S_s; our @ISA = 'VAST::Base';
 678 }
 679
 680
 681 { package VAST::backslash__S_stopper; our @ISA = 'VAST::Base';
 682 }
 683
 684
 685 { package VAST::backslash__S_t; our @ISA = 'VAST::Base';
 686 }
 687
 688
 689 { package VAST::backslash__S_v; our @ISA = 'VAST::Base';
 690 }
 691
 692
 693 { package VAST::backslash__S_w; our @ISA = 'VAST::Base';
 694 }
 695
 696
 697 { package VAST::backslash__S_x; our @ISA = 'VAST::Base';
 698     sub emit_p5 { my $self = shift;
 699         my @t = $self->SUPER::emit_p5;
 700         $t[1] = "{$t[1]}";
 701         @t;
 702     }
 703 }
 704
 705
 706 { package VAST::before; our @ISA = 'VAST::Base';
 707 }
 708
 709
 710 { package VAST::block; our @ISA = 'VAST::Base';
 711 }
 712
 713
 714 { package VAST::blockoid; our @ISA = 'VAST::Base';
 715     sub emit_p5 { my $self = shift;
 716         "{\n" . ::indent(scalar($self->{statementlist}->p5), 1) . "}";
 717     }
 718 }
 719
 720
 721 { package VAST::capterm; our @ISA = 'VAST::Base';
 722 }
 723
 724
 725 { package VAST::cclass_elem; our @ISA = 'VAST::Base';
 726 }
 727
 728
 729 { package VAST::Chaining; our @ISA = ('VAST::Base', 'VAST::InfixCall');
 730 }
 731
 732
 733 { package VAST::circumfix; our @ISA = 'VAST::Base';
 734 }
 735
 736
 737 { package VAST::circumfix__S_Bra_Ket; our @ISA = 'VAST::Base';
 738 }
 739
 740
 741 { package VAST::circumfix__S_Cur_Ly; our @ISA = 'VAST::Base';
 742 }
 743
 744
 745 { package VAST::circumfix__S_Paren_Thesis; our @ISA = 'VAST::Base';
 746 }
 747
 748
 749 { package VAST::circumfix__S_sigil; our @ISA = 'VAST::Base';
 750 }
 751
 752
 753 { package VAST::codeblock; our @ISA = 'VAST::Base';
 754 }
 755
 756
 757 { package VAST::colonpair; our @ISA = 'VAST::Base';
 758     sub adverbs { my $self = shift;
 759         my $val;
 760         if (Scalar::Util::blessed $self->{v} &&
 761                 $self->{v}->isa('VAST::coloncircumfix')) {
 762             my $s = $self->{v}->Str;
 763             my $val = $s =~ /^<\s*(.*?)\s*>$/ ? ::unsingle($1) :
 764                       $s =~ /^«\s*(.*?)\s*»$/ ? ::undouble($1) :
 765                       $s =~ /^\['(.*)'\]$/ ? ::unsingle($1) :
 766                       die "Unparsable coloncircumfix";
 767             return $self->{k} => $val;
 768         } elsif ($self->{v} == 1) {
 769             return "sym" => $self->{k};
 770         } else {
 771             die "Unsupported compile-time adverb " . $self->Str;
 772         }
 773     }
 774 }
 775
 776
 777 { package VAST::Comma; our @ISA = 'VAST::Base';
 778 }
 779
 780
 781
 782 { package VAST::comp_unit; our @ISA = 'VAST::Base';
 783     sub emit_p5 { my $self = shift;
 784         "use 5.010;\nuse utf8;\n" . $self->{statementlist}->p5, "\n";
 785     }
 786     sub emit_p6 { my $self = shift;
 787         substr($ORIG, 0, $self->{statementlist}{BEG}),
 788         $self->{statementlist}->p5;
 789     }
 790     sub emit_psq { my $self = shift;
 791         local %::PRELUDE;
 792         my $body = $self->{statementlist}->psq;
 793         for (sort keys %::PRELUDE) {
 794             my $fn = $_;
 795             $fn =~ s#::#/#g;
 796             $body = "use \"$fn.psq\";\n$body";
 797         }
 798         $body;
 799     }
 800 }
 801
 802 { package VAST::Concatenation; our @ISA = ('VAST::Base', 'VAST::InfixCall');
 803 }
 804
 805
 806 { package VAST::Conditional; our @ISA = 'VAST::Base';
 807     sub emit_p5 {  my $self = shift;
 808         my @t = $self->SUPER::emit_p5;
 809         for (@t) {
 810             s/\?\?/?/;
 811             s/!!/:/;
 812         }
 813         @t;
 814     }
 815 }
 816
 817
 818 { package VAST::CORE; our @ISA = 'VAST::Base';
 819 }
 820
 821
 822 { package VAST::declarator; our @ISA = 'VAST::Base';
 823     sub emit_p5 { my $self = shift;
 824         if ($self->{signature}) {
 825             return "(" . join(", ", map { $_->{param_var}->Str }
 826                 $self->{signature}->kids('parameter')) . ")";
 827         } else {
 828             return $self->SUPER::emit_p5;
 829         }
 830     }
 831
 832     sub emit_psq { my $self = shift;
 833         if ($self->{variable_declarator}) {
 834             $self->{variable_declarator}->psq(@_);
 835         } elsif ($self->{signature}) {
 836             $self->{signature}->psq(@_, declaring => 1);
 837         } elsif ($self->{routine_declarator}) {
 838             $self->{routine_declarator}->psq(@_);
 839         } elsif ($self->{regex_declarator}) {
 840             $self->{regex_declarator}->psq(@_);
 841         } elsif ($self->{type_declarator}) {
 842             $self->{type_declarator}->psq(@_);
 843         }
 844     }
 845 }
 846
 847
 848 { package VAST::default_value; our @ISA = 'VAST::Base';
 849 }
 850
 851
 852 { package VAST::deflongname; our @ISA = 'VAST::Base';
 853     sub adverbs { my $self = shift;
 854         map { $_->adverbs } $self->kids('colonpair');
 855     }
 856 }
 857
 858
 859 { package VAST::def_module_name; our @ISA = 'VAST::Base';
 860 }
 861
 862
 863 { package VAST::desigilname; our @ISA = 'VAST::Base';
 864 }
 865
 866
 867 { package VAST::dotty; our @ISA = 'VAST::Base';
 868 }
 869
 870
 871 { package VAST::dotty__S_Dot; our @ISA = 'VAST::Methodcall';
 872 }
 873
 874
 875 { package VAST::SYM_dotty__S_Dot; our @ISA = 'VAST::Base';
 876 }
 877
 878
 879 { package VAST::dottyop; our @ISA = 'VAST::Base';
 880 }
 881
 882
 883 { package VAST::eat_terminator; our @ISA = 'VAST::Base';
 884 }
 885
 886
 887 { package VAST::escape; our @ISA = 'VAST::Base';
 888 }
 889
 890
 891 { package VAST::escape__S_At; our @ISA = 'VAST::Base';
 892 }
 893
 894
 895 { package VAST::escape__S_Back; our @ISA = 'VAST::Base';
 896 }
 897
 898
 899 { package VAST::escape__S_Dollar; our @ISA = 'VAST::Base';
 900 }
 901
 902
 903 { package VAST::EXPR; our @ISA = 'VAST::Base';
 904 }
 905
 906
 907 { package VAST::fatarrow; our @ISA = 'VAST::Base';
 908 }
 909
 910
 911 { package VAST::fulltypename; our @ISA = 'VAST::Base';
 912 }
 913
 914
 915 { package VAST::hexint; our @ISA = 'VAST::Base';
 916 }
 917
 918
 919 { package VAST::ident; our @ISA = 'VAST::Base';
 920 }
 921
 922
 923 { package VAST::identifier; our @ISA = 'VAST::Base';
 924 }
 925
 926
 927 { package VAST::index; our @ISA = 'VAST::Base';
 928 }
 929
 930
 931
 932 { package VAST::infix; our @ISA = 'VAST::Base';
 933 }
 934
 935 { package VAST::infix_prefix_meta_operator__S_Bang; our @ISA = 'VAST::Base';
 936     sub emit_p5 {  my $self = shift;
 937         my @t = $self->SUPER::emit_p5;
 938         $t[1] = '~' if $t[1] eq '=~';
 939         $t[1] = '=' if $t[1] eq '==';
 940         @t = ('ne', '') if $t[1] eq 'eq';
 941         @t;
 942     }
 943 }
 944
 945 { package VAST::SYM_infix__S_ColonEqual; our @ISA = 'VAST::Item_assignment';
 946     sub emit_p5 {  my $self = shift;
 947         my @t = $self->SUPER::emit_p5;
 948         $t[0] = '=';    # XXX oversimplified
 949         @t;
 950     }
 951 }
 952
 953 { package VAST::SYM_infix__S_ColonColonEqual; our @ISA = 'VAST::Item_assignment';
 954     sub emit_p5 {  my $self = shift;
 955         my @t = $self->SUPER::emit_p5;
 956         $t[0] = '=';    # XXX oversimplified
 957         @t;
 958     }
 959 }
 960
 961
 962 { package VAST::infixish; our @ISA = 'VAST::Base';
 963 }
 964
 965
 966 { package VAST::SYM_infix__S_PlusAmp; our @ISA = 'VAST::Multiplicative';
 967     sub emit_p5 {  my $self = shift;
 968         my @t = $self->SUPER::emit_p5;
 969         $t[0] = '&';
 970         @t;
 971     }
 972 }
 973
 974 { package VAST::SYM_infix__S_eqv; our @ISA = 'VAST::Chaining';
 975     sub emit_p5 {  my $self = shift;
 976         my @t = $self->SUPER::emit_p5;
 977         $t[0] = 'eq';
 978         @t;
 979     }
 980 }
 981
 982 { package VAST::SYM_infix__S_leg; our @ISA = 'VAST::Structural_infix';
 983     sub emit_p5 {  my $self = shift;
 984         my @t = $self->SUPER::emit_p5;
 985         $t[0] = 'cmp';
 986         @t;
 987     }
 988 }
 989
 990 { package VAST::SYM_infix__S_EqualEqualEqual; our @ISA = 'VAST::Chaining';
 991     sub emit_p5 {  my $self = shift;
 992         my @t = $self->SUPER::emit_p5;
 993         $t[0] = '=='; # only correct for objects (and ints)
 994         @t;
 995     }
 996 }
 997
 998 { package VAST::SYM_infix__S_orelse; our @ISA = 'VAST::Loose_or';
 999     sub emit_p5 {  my $self = shift;
1000         my @t = $self->SUPER::emit_p5;
1001         $t[0] = ' or ';
1002         @t;
1003     }
1004 }
1005
1006 { package VAST::SYM_infix__S_andthen; our @ISA = 'VAST::Loose_and';
1007     sub emit_p5 {  my $self = shift;
1008         my @t = $self->SUPER::emit_p5;
1009         $t[0] = ' and ';
1010         @t;
1011     }
1012 }
1013
1014 { package VAST::SYM_infix__S_PlusVert; our @ISA = 'VAST::Additive';
1015     sub emit_p5 {  my $self = shift;
1016         my @t = $self->SUPER::emit_p5;
1017         $t[0] = '|';
1018         @t;
1019     }
1020 }
1021
1022
1023 { package VAST::SYM_infix__S_Tilde; our @ISA = 'VAST::Concatenation';
1024     sub emit_p5 {  my $self = shift;
1025         my @t = $self->SUPER::emit_p5;
1026         $t[0] = '.';
1027         @t;
1028     }
1029 }
1030
1031
1032 { package VAST::SYM_infix__S_TildeTilde; our @ISA = 'VAST::Chaining';
1033     sub emit_p5 {  my $self = shift;
1034         my @t = $self->SUPER::emit_p5;
1035         $t[0] = '=~';
1036         @t;
1037     }
1038 }
1039
1040 { package VAST::SYM_infix__S_TildeVert; our @ISA = 'VAST::Additive';
1041     sub emit_p5 {  my $self = shift;
1042         my @t = $self->SUPER::emit_p5;
1043         $t[0] = '|';
1044         @t;
1045     }
1046 }
1047
1048
1049 { package VAST::integer; our @ISA = 'VAST::Base';
1050 }
1051
1052
1053 { package VAST::Item_assignment; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1054 }
1055
1056
1057 { package VAST::Junctive_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1058 }
1059
1060
1061 { package VAST::label; our @ISA = 'VAST::Base';
1062 }
1063
1064
1065 { package VAST::lambda; our @ISA = 'VAST::Base';
1066     sub emit_p5 {  my $self = shift;
1067         my @t = $self->SUPER::emit_p5;
1068         $t[0] = 'sub';
1069         @t;
1070     }
1071 }
1072
1073
1074 { package VAST::left; our @ISA = 'VAST::Base';
1075 }
1076
1077
1078 { package VAST::List_assignment; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1079 }
1080
1081
1082 { package VAST::litchar; our @ISA = 'VAST::Base';
1083 }
1084
1085
1086 { package VAST::longname; our @ISA = 'VAST::Base';
1087     sub adverbs { my $self = shift;
1088         map { $_->adverbs } $self->kids('colonpair');
1089     }
1090 }
1091
1092
1093 { package VAST::Loose_and; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1094 }
1095
1096
1097 { package VAST::Loose_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1098 }
1099
1100
1101 { package VAST::Loose_unary; our @ISA = 'VAST::Base';
1102 }
1103
1104
1105 { package VAST::metachar; our @ISA = 'VAST::Base';
1106     sub re_ast {  my $self = shift;
1107         RE_meta->new(text => $self->Str);
1108     }
1109 }
1110
1111
1112 { package VAST::metachar__S_Back; our @ISA = 'VAST::metachar';
1113     sub re_ast {  my $self = shift;
1114         RE_meta->new(text => $self->Str, min => 1);
1115     }
1116 }
1117
1118
1119 { package VAST::metachar__S_Bra_Ket; our @ISA = 'VAST::Base';
1120     sub re_ast {  my $self = shift;
1121         local $::DBA = $::DBA;
1122         local $::RATCHET = $::RATCHET;
1123         local $::SIGSPACE = $::SIGSPACE;
1124         local $::IGNORECASE = $::IGNORECASE;
1125         local @::DECLAST;
1126
1127         my $bodyast = $self->{nibbler}{"."}->re_ast;
1128         RE_bracket->new(decl => \@::DECLAST, re => $bodyast);
1129     }
1130 }
1131
1132
1133 { package VAST::metachar__S_Caret; our @ISA = 'VAST::metachar';
1134 }
1135
1136
1137 { package VAST::metachar__S_CaretCaret; our @ISA = 'VAST::metachar';
1138 }
1139
1140 { package VAST::metachar__S_ColonColon; our @ISA = 'VAST::metachar';
1141 }
1142
1143 { package VAST::metachar__S_ColonColonColon; our @ISA = 'VAST::metachar';
1144 }
1145
1146 { package VAST::metachar__S_ColonColonKet; our @ISA = 'VAST::metachar';
1147 }
1148
1149
1150 { package VAST::metachar__S_Cur_Ly; our @ISA = 'VAST::Base';
1151     sub re_ast { my $self = shift;
1152         local $::NEEDMATCH = 0;
1153         my $text = $self->{embeddedblock}{statementlist}->p5;
1154         $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
1155         RE_block->new(body => $text, context => 'void');
1156     }
1157 }
1158
1159
1160 { package VAST::metachar__S_Dollar; our @ISA = 'VAST::metachar';
1161 }
1162
1163
1164 { package VAST::metachar__S_DollarDollar; our @ISA = 'VAST::metachar';
1165 }
1166
1167
1168 { package VAST::metachar__S_Dot; our @ISA = 'VAST::metachar';
1169     sub re_ast {  my $self = shift;
1170         RE_meta->new(text => $self->Str, min => 1);
1171     }
1172 }
1173
1174
1175 { package VAST::metachar__S_Double_Double; our @ISA = 'VAST::Base';
1176     sub re_ast {  my $self = shift;
1177         my $text = ::undouble($self->{quote}{nibble}->Str);
1178         RE_double->new(text => $text);
1179     }
1180 }
1181
1182
1183 { package VAST::metachar__S_Lt_Gt; our @ISA = 'VAST::Base';
1184     sub re_ast {  my $self = shift;
1185         $self->{assertion}->re_ast;
1186     }
1187 }
1188
1189
1190 { package VAST::metachar__S_mod; our @ISA = 'VAST::Base';
1191     sub re_ast {  my $self = shift;
1192         $self->{mod_internal}->re_ast;
1193     }
1194 }
1195
1196
1197 { package VAST::metachar__S_Nch; our @ISA = 'VAST::metachar';
1198 }
1199
1200
1201 { package VAST::metachar__S_Paren_Thesis; our @ISA = 'VAST::Base';
1202     sub re_ast {  my $self = shift;
1203         local $::DBA = $::DBA;
1204         local $::RATCHET = $::RATCHET;
1205         local $::SIGSPACE = $::SIGSPACE;
1206         local $::IGNORECASE = $::IGNORECASE;
1207         local @::DECLAST;
1208
1209         my $bodyast = $self->{nibbler}{"."}->re_ast;
1210         # XXX STD gimme5 disables binding to $0 in $<foo> = (bar)
1211         my $inner = RE_paren->new(decl => \@::DECLAST, re => $bodyast);
1212         $::PARSENAME ? $inner : RE_bindpos->new(var => $::PAREN++, atom => $inner)
1213     }
1214 }
1215
1216
1217 { package VAST::metachar__S_qw; our @ISA = 'VAST::Base';
1218     sub re_ast {  my $self = shift;
1219         # XXX
1220         my @elems = split(' ', $self->{circumfix}{nibble}->Str);
1221         shift @elems;
1222         my $l = ::min(1_000_000_000, map { length } @elems);
1223         RE_qw->new(min => $l, text => $self->Str);
1224     }
1225 }
1226
1227
1228 { package VAST::metachar__S_sigwhite; our @ISA = 'VAST::Base';
1229     sub re_ast {  my $self = shift;
1230         $::SIGSPACE ?
1231             RE_method->new(name => 'ws', nobind => 1) :
1232             RE_noop->new;
1233     }
1234 }
1235
1236
1237 { package VAST::metachar__S_Single_Single; our @ISA = 'VAST::Base';
1238     sub re_ast {  my $self = shift;
1239         my $text = ::unsingle($self->{quote}{nibble}->Str);
1240         RE_string->new(text => $text);
1241     }
1242 }
1243
1244
1245 { package VAST::metachar__S_var; our @ISA = 'VAST::Base';
1246     sub re_ast {  my $self = shift;
1247         # We don't un6 because some things need to un6 specially - backrefs
1248         if ($self->{binding}) {
1249             local $::PARSENAME = 1;
1250             $self->{SYM} =~ /^\$<(.*)>$/ or die "Can't bind backref to " . $self->{SYM};
1251             RE_bindnamed->new(var => $1, atom =>
1252                 $self->{binding}{quantified_atom}->re_ast);
1253         } else {
1254             RE_var->new(var => $self->{termish}->p5);
1255         }
1256     }
1257 }
1258
1259
1260 { package VAST::Methodcall; our @ISA = 'VAST::Base';
1261     sub emit_p5 {  my $self = shift;
1262         my @t = $self->SUPER::emit_p5;
1263         if (@t > 2) {
1264             my $first = shift @t;
1265             my $second = join '', @t;
1266             @t = ($first,$second);
1267         }
1268         if ($t[1] eq '.pos') { $t[1] = '.<_pos>'; }
1269         $t[1] =~ s/^(\.?)<(.*)>$/$1\{'$2'\}/;
1270         if ($t[0] =~ /^[@%]/) {
1271             if ($t[1] =~ s/^\.?([[{])/$1/) {
1272                 if ($t[1] =~ /,/) {
1273                     substr($t[0],0,1) = '@';
1274                 }
1275                 else {
1276                     substr($t[0],0,1) = '$';
1277                 }
1278
1279             }
1280         }
1281         elsif ($t[1] =~ /^[[{]/) {
1282             $t[1] =~ s/^([[{])/.$1/;
1283         }
1284         elsif ($t[0] =~ s/^&(\w+)/\$$1/) {
1285             $t[1] =~ s/^\(/->(/;
1286         }
1287         $t[1] =~ s/^\./->/;
1288         my $t = join('', @t);
1289         $t =~ s/^(.*\S)\s*:(delete|exists)/$2 $1/;
1290 #       print STDERR ::Dump(\@t);
1291         $t;
1292     }
1293 }
1294
1295
1296 { package VAST::method_def; our @ISA = 'VAST::Base';
1297     sub emit_p5 {  my $self = shift;
1298         my $name = $self->{longname} ? $self->{longname}->p5 . " " : "";
1299         my $sig  = $self->{multisig}[0] ? $self->{multisig}[0]->p5 : "";
1300         my $body = $self->{blockoid}{statementlist}->p5;
1301
1302         if ($::MULTINESS eq 'multi') {
1303             $::MULTIMETHODS{$name} .= <<EOT
1304 {
1305     local \@_ = \@_;
1306     return scalar do { # work around #38809
1307         my \$self = shift;
1308 EOT
1309             . ::indent($sig . $body, 2) . <<EOT
1310     };
1311 }
1312 EOT
1313             ;
1314             return '';
1315         }
1316
1317         # not quite right, this should be an expression
1318         ($name eq 'EXPR' ? # XXX STD
1319             "sub EXPR__PEEK { \$_[0]->_AUTOLEXpeek(\'EXPR\',\$retree) }\n" : '').
1320         "sub " . $name . "{\n" .
1321             ::indent("no warnings 'recursion';\nmy \$self = shift;\n" .
1322                 $sig . $body, 1)
1323         . "}";
1324     }
1325 }
1326
1327
1328 { package VAST::methodop; our @ISA = 'VAST::Base';
1329 }
1330
1331
1332 { package VAST::modifier_expr; our @ISA = 'VAST::Base';
1333 }
1334
1335
1336 { package VAST::mod_internal; our @ISA = 'VAST::Base';
1337 }
1338
1339
1340 { package VAST::mod_internal__S_p6adv; our @ISA = 'VAST::Base';
1341     sub re_ast { my $self = shift;
1342         my $key = $self->{quotepair}{k};
1343
1344         if ($key eq 'dba') {
1345             $::DBA = eval ($self->{quotepair}{circumfix}[0]->Str);
1346         } elsif ($key eq 'lang') {
1347             my $lang = $self->{quotepair}{circumfix}[0]->p5;
1348             return RE_decl->new(body => <<BODY);
1349 my \$newlang = $lang;
1350 \$C = bless(\$C, (ref(\$newlang) || \$newlang));
1351 BODY
1352         } else {
1353             die "unhandled internal adverb $key";
1354         }
1355
1356         RE_noop->new;
1357     }
1358 }
1359
1360
1361 { package VAST::mod_internal__S_ColonBangs; our @ISA = 'VAST::Base';
1362 }
1363
1364
1365 { package VAST::mod_internal__S_Coloni; our @ISA = 'VAST::Base';
1366     sub re_ast { my $self = shift;
1367         $::IGNORECASE = 1;
1368         RE_noop->new;
1369     }
1370 }
1371
1372 { package VAST::mod_internal__S_Colonr; our @ISA = 'VAST::Base';
1373     sub re_ast { my $self = shift;
1374         $::RATCHET = 1;
1375         RE_noop->new;
1376     }
1377 }
1378
1379
1380 { package VAST::mod_internal__S_Colonmy; our @ISA = 'VAST::Base';
1381     sub re_ast { my $self = shift;
1382         local $::NEEDMATCH = 0;
1383         my $text = $self->{statement}->p5 . ";";
1384         $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH;
1385
1386         push @::DECLAST, RE_decl->new(body => $text);
1387         RE_noop->new;
1388     }
1389 }
1390
1391
1392 { package VAST::mod_internal__S_Colons; our @ISA = 'VAST::Base';
1393     sub re_ast { my $self = shift;
1394         $::SIGSPACE = 1;
1395         RE_noop->new;
1396     }
1397 }
1398
1399
1400 { package VAST::mod_internal__S_ColonBangs; our @ISA = 'VAST::Base';
1401     sub re_ast { my $self = shift;
1402         $::SIGSPACE = 0;
1403         RE_noop->new;
1404     }
1405 }
1406
1407
1408 { package VAST::module_name; our @ISA = 'VAST::Base';
1409 }
1410
1411
1412 { package VAST::module_name__S_normal; our @ISA = 'VAST::Base';
1413 }
1414
1415
1416 { package VAST::morename; our @ISA = 'VAST::Base';
1417 }
1418
1419
1420 { package VAST::multi_declarator; our @ISA = 'VAST::Base';
1421     sub emit_psq { my $self = shift;
1422         if ($self->{declarator}) {
1423             $self->{declarator}->psq(@_, multiness => $self->{SYM});
1424         } else {
1425             $self->{routine_def}->psq(@_, multiness => $self->{SYM});
1426         }
1427     }
1428 }
1429
1430
1431 { package VAST::multi_declarator__S_multi; our @ISA = 'VAST::multi_declarator';
1432     sub emit_p5 {  my $self = shift;
1433         local $::MULTINESS = 'multi';
1434         $self->{"."}->p5;
1435     }
1436 }
1437
1438
1439 { package VAST::multi_declarator__S_null; our @ISA = 'VAST::multi_declarator';
1440 }
1441
1442
1443 { package VAST::multi_declarator__S_proto; our @ISA = 'VAST::multi_declarator';
1444     sub emit_p5 {  my $self = shift;
1445         local $::MULTINESS = 'proto';
1446         $self->{"."}->p5;
1447     }
1448 }
1449
1450
1451 { package VAST::Multiplicative; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1452 }
1453
1454 # We don't currently do MMD so no need for later sigs
1455 { package VAST::multisig; our @ISA = 'VAST::Base';
1456     sub emit_p5 {  my $self = shift;
1457         $self->{signature}[0]->p5;
1458     }
1459 }
1460
1461
1462 { package VAST::name; our @ISA = 'VAST::Base';
1463 }
1464
1465
1466 { package VAST::named_param; our @ISA = 'VAST::Base';
1467 }
1468
1469
1470 { package VAST::Named_unary; our @ISA = 'VAST::Base';
1471 }
1472
1473 { package VAST::nibbler; our @ISA = 'VAST::Base';
1474 }
1475
1476
1477 { package VAST::nofun; our @ISA = 'VAST::Base';
1478 }
1479
1480
1481 { package VAST::normspace; our @ISA = 'VAST::Base';
1482 }
1483
1484
1485
1486 { package VAST::nulltermish; our @ISA = 'VAST::Base';
1487 }
1488
1489
1490 { package VAST::number; our @ISA = 'VAST::Base';
1491     sub emit_psq { my $self = shift;
1492         die "unsupported literal format" unless $self->{integer}{decint};
1493         my $str = $self->{integer}{decint}->Str;
1494         $str =~ y/_//d;
1495         $str;
1496     }
1497 }
1498
1499
1500 { package VAST::number__S_numish; our @ISA = 'VAST::Base';
1501 }
1502
1503
1504 { package VAST::numish; our @ISA = 'VAST::Base';
1505 }
1506
1507
1508 { package VAST::opener; our @ISA = 'VAST::Base';
1509 }
1510
1511
1512 { package VAST::package_declarator; our @ISA = 'VAST::Base';
1513     sub emit_psq {  my $self = shift;
1514         local $::PKGDECL = $self->{SYM};
1515         $self->{package_def}->psq;
1516     }
1517 }
1518
1519
1520 { package VAST::package_declarator__S_class; our @ISA = 'VAST::package_declarator';
1521     sub emit_p5 {  my $self = shift;
1522         local $::PKGDECL = 'class';
1523         $self->{package_def}->p5;
1524     }
1525 }
1526
1527
1528 { package VAST::package_declarator__S_grammar; our @ISA = 'VAST::package_declarator';
1529     sub emit_p5 {  my $self = shift;
1530         local $::PKGDECL = 'grammar';
1531         $self->{package_def}->p5;
1532     }
1533 }
1534
1535
1536 { package VAST::package_declarator__S_role; our @ISA = 'VAST::package_declarator';
1537     sub emit_p5 {  my $self = shift;
1538         local $::PKGDECL = 'role';
1539         $self->{package_def}->p5;
1540     }
1541 }
1542
1543 { package VAST::package_declarator__S_knowhow; our @ISA = 'VAST::package_declarator';
1544     sub emit_p5 {  my $self = shift;
1545         local $::PKGDECL = 'knowhow';
1546         $self->{package_def}->p5;
1547     }
1548 }
1549
1550
1551 { package VAST::package_def; our @ISA = 'VAST::Base';
1552     sub module_name {  my $self = shift;
1553         my $def_module_name = $self->{longname}[0]{name}->Str;
1554         if ($self->{decl}{inpkg}[0] =~ /GLOBAL::(.*)/) {
1555             my $mod = $1;
1556             for ($mod) { s/::::/::/g; s/^:://; s/::$//; } # XXX STD misparse?
1557             $::OUR{$def_module_name} = "${mod}::$def_module_name";
1558             $def_module_name = "${mod}::$def_module_name";
1559         }
1560         $def_module_name;
1561     }
1562     sub superclasses {  my $self = shift;
1563         my @extends;
1564         for (@{$self->{trait}}) {
1565             my $t = $_->Str;
1566             push(@extends, $t =~ /^is\s+(\S+)/);
1567         }
1568         @extends = map { $::OUR{$_} // $_ } @extends;
1569         @extends = 'Cursor' if $::PKGDECL eq 'grammar' && !@extends;
1570         @extends;
1571     }
1572     sub roles { my $self = shift;
1573         my @does;
1574         for (@{$self->{trait}}) {
1575             my $t = $_->Str;
1576             push(@does,    $t =~ /^does\s+(\S+)/);
1577         }
1578         @does    = map { $::OUR{$_} // $_ } @does;
1579     }
1580     sub emit_p5_header {  my $self = shift;
1581         my $header = "";
1582         my $name = $::PKG;
1583
1584         my $meta = $::PKGDECL eq 'role' ? 'Moose::Role' : 'Moose';
1585
1586         $header .= <<"END";
1587 use $meta ':all' => { -prefix => "moose_" };
1588 use Encode;
1589 END
1590
1591         $header .= <<"END" for $self->superclasses;
1592 moose_extends('$_');
1593 END
1594
1595         $header .= <<"END" for $self->roles;
1596 moose_with('$_');
1597 END
1598
1599         if (! $self->roles) {
1600             $header .= "our \$ALLROLES = { '$::PKG', 1 };\n";
1601         }
1602
1603         $header .= "our \$REGEXES = {\n";
1604         $::PROTORX_HERE{ALL} = [ sort keys %::OVERRIDERX ];
1605         for my $p (sort keys %::PROTORX_HERE) {
1606             $header .= "    $p => [ qw/" . join(" ",
1607                 @{ $::PROTORX_HERE{$p} }) . "/ ],\n";
1608         }
1609         $header .= "};\n\n";
1610
1611         $header .= <<"END";
1612
1613 no warnings 'qw', 'recursion';
1614 my \$retree;
1615
1616 \$DB::deep = \$DB::deep = 1000; # suppress used-once warning
1617
1618 use YAML::XS;
1619
1620 \$SIG{__WARN__} = sub { die \@_,"   statement started at line ", 'Cursor'->lineof(\$::LASTSTATE), "\n" } if \$::DEBUG;
1621
1622 END
1623         $header;
1624     }
1625
1626     sub emit_p5 {  my $self = shift;
1627         my $block = $self->{blockoid}{statementlist} // $self->{statementlist};
1628         local $::RETREE = {};
1629         local $::PKG = $self->module_name;
1630         local $::MULTIRX_SEQUENCE = 0;
1631         local %::PROTORX_HERE;
1632         local %::OVERRIDERX;
1633         local %::MULTIMETHODS;
1634         my $body3 = $block->p5;
1635         my $body1 = $self->emit_p5_header;
1636         my $body2 = '';
1637
1638         if (%{$::RETREE}) {
1639             $body2 = "\$retree = YAML::XS::Load(Encode::encode_utf8(<<'RETREE_END'));\n" .
1640                 Encode::decode_utf8(::Dump($::RETREE)) . "RETREE_END\n";
1641         }
1642         my $body = $body1 . $body2 . $body3;
1643         my $name  = $::PKG;
1644
1645         if (my ($sig) = $self->kids('signature')) {
1646             my @parm = map { $_->Str } $sig->kids('parameter');
1647             my $plist = join ", ", @parm;
1648
1649             $body = <<EOT . $body;
1650     package $name;
1651     require "mangle.pl";
1652     our \%INSTANTIATED;
1653     sub __instantiate__ { my \$self = shift;
1654         my ($plist) = \@_;
1655         my \$mangle = ::mangle($plist);
1656         my \$mixin = "${name}::" . \$mangle;
1657         return \$mixin if \$INSTANTIATED{\$mixin}++;
1658         ::deb("         instantiating \$mixin") if \$::DEBUG & DEBUG::mixins;
1659         my \$eval = "package \$mixin" . q{;
1660             sub _PARAMS { { ${\ join(", ", map { "'$_' => $_" } @parm) } } }
1661 EOT
1662             $body .= <<EOT;
1663         };
1664         eval \$eval;
1665         die \$@ if \$@;
1666         return \$mixin;
1667     }
1668 EOT
1669         } else {
1670             $body = "package $name;\n" . $body;
1671         }
1672
1673         my $finalmulti = '';
1674
1675         for my $mm (sort keys %::MULTIMETHODS) {
1676             $finalmulti .= "moose_around $mm => sub {\n    my \$orig = shift;\n    no warnings 'recursion';\n" .
1677                 ::indent($::MULTIMETHODS{$mm}, 1) . <<EOFINAL
1678     \$orig->(\@_);
1679 };
1680
1681 EOFINAL
1682                 ;
1683         }
1684
1685         "{ $body $finalmulti 1; }";
1686     }
1687
1688     sub psq_finish_multis { my $self = shift;
1689         die "multis not yet implemented for psq";
1690     }
1691
1692     sub psq_retree { my $self = shift;
1693         die "LTM not yet implemented for psq";
1694     }
1695
1696     sub psq_parameterized { my $self = shift;
1697         die "roles not yet implemented for psq";
1698     }
1699
1700     sub psq_plain { my $self = shift; my $body = shift;
1701         die "roles not yet implemented for psq"
1702             if $::PKGDECL eq 'role' or $self->roles;
1703         die "multiple inheritance not available in psq"
1704             if $self->superclasses > 1;
1705         my ($is) = $self->superclasses;
1706         "class " . $::PKG . " " . ($is ? "is $is " : "") .
1707             "{\n" . ::indent($body) . "\n}";
1708     }
1709
1710     sub emit_psq {  my $self = shift;
1711         my $block = $self->{blockoid}{statementlist} // $self->{statementlist};
1712         local $::RETREE = {};
1713         local $::PKG = $self->module_name;
1714         local $::MULTIRX_SEQUENCE = 0;
1715         local %::MULTIMETHODS;
1716
1717         my $body = $block->psq;
1718         $body = $body . $self->psq_finish_multis
1719             if %::MULTIMETHODS;
1720         $body = $self->psq_retree . $body
1721             if %$::RETREE;
1722
1723         if (my ($sig) = $self->kids('signature')) {
1724             $body = $self->psq_parameterized($body,
1725                 map { $_->Str } $sig->kids('parameter'));
1726         } else {
1727             $body = $self->psq_plain($body);
1728         }
1729
1730         $body;
1731     }
1732 }
1733
1734 # Perl5 invocations don't carry enough context for a proper binder; in
1735 # particular we can't distinguish named stuff from positionals
1736 { package VAST::parameter; our @ISA = 'VAST::Base';
1737     sub emit_p5 {  my $self = shift;
1738         my $pvar = $self->{param_var};
1739         my @names;
1740         my $posit = 0;
1741
1742         my $np = $self->{named_param};
1743         while ($np) {
1744             $pvar = $np->{param_var};
1745             push @names, $np->{name} ? $np->{name}{TEXT}
1746                 : $np->{param_var}{name}[0]{TEXT};
1747             $np = $np->{named_param};
1748         }
1749         $posit = 1 unless @names;
1750         my $pname = $pvar->{name}[0]{TEXT};
1751         my $sigil = $pvar->{sigil}{SYM};
1752         my $twigil = $pvar->{twigil}[0] ? $pvar->{twigil}[0]{SYM} : '';
1753         my ($dv) = $self->kids('default_value');
1754
1755         # Is it valid?
1756         my $check = '';
1757         if (($self->{quant} eq '!' || $self->{quant} eq '' && $posit) && !$dv) {
1758             $check .= $::MULTINESS eq 'multi' ? "last " :
1759                 "die 'Required argument $pname omitted' ";
1760             $check .= $posit ? 'unless @_'
1761                 : 'unless ' . join(" || ", map ("exists \$args{$_}", @names));
1762             $check .= ";\n"
1763         }
1764
1765         # Get the value
1766         my $value = "undef";
1767         if ($dv) {
1768             $value = $dv->{"."}->p5;
1769         }
1770         if ($posit) {
1771             $value = '@_ ? shift() : ' . $value;
1772         }
1773         for (reverse @names) {
1774             $value = "exists \$args{$_} ? delete \$args{$_} : $value";
1775         }
1776         if ($self->{quant} eq '*') {
1777             $value = ($sigil eq '%') ? '%args' : '@_';
1778             $posit = 0 if $sigil eq '%';
1779         }
1780
1781         # Store it somewhere useful
1782         if ($twigil eq '*' && $pname eq 'endsym') {
1783             # XXX this optimization needs to be refactored, I think
1784             my ($dv) = $self->kids('default_value');
1785             $::ENDSYM = $dv->{"."}->Str;
1786             $::ENDSYM = substr($::ENDSYM, 1, length($::ENDSYM)-2);
1787             return (0, '');
1788         }
1789
1790         my $assn;
1791         if ($twigil eq '*') {
1792             $assn = "local ${sigil}::${pname} = $value";
1793         } else {
1794             $assn = "my ${sigil}${pname} = $value";
1795         }
1796
1797         (!$posit), ($check . $assn);
1798     }
1799 }
1800
1801
1802 { package VAST::param_sep; our @ISA = 'VAST::Base';
1803 }
1804
1805
1806 { package VAST::param_var; our @ISA = 'VAST::Base';
1807 }
1808
1809
1810 { package VAST::pblock; our @ISA = 'VAST::Base';
1811 }
1812
1813
1814 { package VAST::pod_comment; our @ISA = 'VAST::Base';
1815 }
1816
1817
1818 { package VAST::POST; our @ISA = 'VAST::Base';
1819 }
1820
1821
1822 { package VAST::postcircumfix; our @ISA = 'VAST::Base';
1823 }
1824
1825
1826 { package VAST::SYM_postcircumfix__S_Lt_Gt; our @ISA = 'VAST::Base';
1827     sub emit_p5 {  my $self = shift;
1828         my @t = $self->SUPER::emit_p5;
1829         $t[0] = "{'";
1830         $t[-1] = "'}";
1831         @t;
1832     }
1833 }
1834
1835
1836 { package VAST::postfix; our @ISA = 'VAST::Base';
1837 }
1838
1839
1840 { package VAST::postop; our @ISA = 'VAST::Base';
1841 }
1842
1843
1844 { package VAST::PRE; our @ISA = 'VAST::Base';
1845 }
1846
1847
1848 { package VAST::prefix; our @ISA = 'VAST::Base';
1849 }
1850
1851
1852 { package VAST::SYM_prefix__S_Plus; our @ISA = 'VAST::Symbolic_unary';
1853     sub emit_p5 {  my $self = shift;
1854         my @t = $self->SUPER::emit_p5;
1855         $t[0] = '0+';
1856         @t;
1857     }
1858 }
1859
1860 { package VAST::SYM_prefix__S_Vert; our @ISA = 'VAST::Symbolic_unary';
1861     sub emit_p5 {  my $self = shift;
1862         ('');
1863     }
1864 }
1865
1866
1867 { package VAST::prefix__S_temp; our @ISA = 'VAST::Base';
1868     sub emit_p5 {  my $self = shift;
1869         my $arg = $self->{arg}->p5;
1870         "local $arg = $arg";
1871     }
1872 }
1873
1874
1875 { package VAST::quantified_atom; our @ISA = 'VAST::Base';
1876     sub re_ast {  my $self = shift;
1877         if (!@{$self->{quantifier}}) {
1878             return $self->{atom}->re_ast;
1879         }
1880
1881         if ($self->{quantifier}[0]{SYM} eq '~') {
1882             return $self->_tilde;
1883         }
1884
1885         if ($self->{quantifier}[0]{SYM} eq ':') {
1886             my $ast = $self->{atom}->re_ast;
1887             $ast->{r} = 1;
1888             return $ast;
1889         }
1890
1891         my $quant = $self->{quantifier}[0]->re_quantifier;
1892
1893         my $ast = $self->{atom}->re_ast;
1894
1895         my $r = RE_quantified_atom->new(atom => $ast, quant => $quant);
1896         $r->{r} = 0 if $quant->[1] ne ':';
1897         $r;
1898     }
1899
1900     sub _tilde {  my $self = shift;
1901         my $opener = $self->{atom}->re_ast;
1902         my $closer = $self->{quantifier}[0]{quantified_atom}[0]->re_ast;
1903         my $inner  = $self->{quantifier}[0]{quantified_atom}[1]->re_ast;
1904
1905         my $strcloser = $closer->{text}; #XXX
1906
1907         my $begin = <<TEXT;
1908 local \$::GOAL = "${\ quotemeta $strcloser}";
1909 my \$goalpos = \$C;
1910 TEXT
1911         if ($strcloser !~ /^[])}]$/) {
1912             $begin .= <<TEXT;
1913 my \$newlang = \$C->unbalanced(\$::GOAL);
1914 \$C = bless(\$C, (ref(\$newlang) || \$newlang));
1915 TEXT
1916         }
1917
1918         my @expn;
1919         push @expn, $opener;
1920         # XXX STD break LTM for gimme5 bug-compatibility
1921         push @expn, RE_block->new(body => '', context => 'void');
1922         push @expn, $inner;
1923         push @expn, RE_bracket->new(decl => [], re => RE_first->new(
1924                 RE_string->new(text => $strcloser),
1925                 RE_method->new(name => 'FAILGOAL', nobind => 1,
1926                     rest => "(\$::GOAL, '$::DBA', \$goalpos)")));
1927
1928         RE_bracket->new(decl => [RE_decl->new(body => $begin)], re =>
1929             RE_sequence->new(@expn));
1930     }
1931 }
1932
1933 { package VAST::quant_atom_list; our @ISA = 'VAST::Base';
1934     sub re_ast {  my $self = shift;
1935         my @kids = map { $_->re_ast } $self->kids("quantified_atom");
1936         RE_sequence->new(@kids);
1937     }
1938 }
1939
1940
1941 { package VAST::quantifier; our @ISA = 'VAST::Base';
1942 }
1943
1944
1945 { package VAST::quantifier__S_Plus; our @ISA = 'VAST::Base';
1946     sub re_quantifier { my $self = shift;
1947         $self->base_re_quantifier("", 1);
1948     }
1949 }
1950
1951
1952 { package VAST::quantifier__S_Question; our @ISA = 'VAST::Base';
1953     sub re_quantifier { my $self = shift;
1954         $self->base_re_quantifier("", 0);
1955     }
1956 }
1957
1958
1959 { package VAST::quantifier__S_Star; our @ISA = 'VAST::Base';
1960     sub re_quantifier { my $self = shift;
1961         $self->base_re_quantifier("", 0);
1962     }
1963 }
1964
1965
1966 { package VAST::quantifier__S_StarStar; our @ISA = 'VAST::Base';
1967     sub re_quantifier { my $self = shift;
1968         my ($range) = $self->Str =~ /.*(\d+\.\.\d+)$/;
1969         $self->base_re_quantifier($self->{embeddedblock} //
1970             $range // $self->{quantified_atom}->re_ast, 1);
1971     }
1972 }
1973
1974
1975 { package VAST::quantmod; our @ISA = 'VAST::Base';
1976 }
1977
1978
1979 { package VAST::quibble; our @ISA = 'VAST::Base';
1980 }
1981
1982
1983
1984 { package VAST::quote; our @ISA = 'VAST::Base';
1985     sub emit_p5 {  my $self = shift;
1986         my @t = $self->SUPER::emit_p5;
1987         $t[0] =~ s/</qw</;
1988 #       print STDERR ::Dump(\@t);
1989         @t;
1990     }
1991 }
1992
1993 { package VAST::quote__S_Double_Double; our @ISA = 'VAST::Base';
1994 }
1995
1996
1997 { package VAST::circumfix__S_Fre_Nch; our @ISA = 'VAST::Base';
1998     sub emit_p5 {  my $self = shift;
1999         '[split(/ /, "' . $self->{nibble}->p5 . '", -1)]'
2000     }
2001 }
2002
2003
2004 { package VAST::quote__S_Lt_Gt; our @ISA = 'VAST::Base';
2005 }
2006
2007
2008 { package VAST::quotepair; our @ISA = 'VAST::Base';
2009 }
2010
2011
2012 { package VAST::quote__S_s; our @ISA = 'VAST::Base';
2013 }
2014
2015
2016 { package VAST::quote__S_Single_Single; our @ISA = 'VAST::Base';
2017     sub emit_psq { my $self = shift;
2018         my $str = $self->Str;
2019         $str;
2020     }
2021 }
2022
2023
2024 { package VAST::quote__S_Slash_Slash; our @ISA = 'VAST::Base';
2025 }
2026
2027
2028 { package VAST::regex_block; our @ISA = 'VAST::Base';
2029 }
2030
2031
2032 { package VAST::regex_declarator; our @ISA = 'VAST::Base';
2033 }
2034
2035
2036 { package VAST::regex_declarator__S_regex; our @ISA = 'VAST::Base';
2037     sub emit_p5 {  my $self = shift;
2038         local $::RATCHET = 0;
2039         local $::SIGSPACE = 0;
2040         local $::REGEX_DECLARATOR = 'regex';
2041         my $comment = substr($ORIG, $self->{BEG},100);
2042         $comment =~ s/\n.*//s;
2043         "## $comment\n" . $self->{regex_def}->p5;
2044     }
2045 }
2046
2047
2048 { package VAST::regex_declarator__S_rule; our @ISA = 'VAST::Base';
2049     sub emit_p5 {  my $self = shift;
2050         local $::RATCHET = 1;
2051         local $::SIGSPACE = 1;
2052         local $::REGEX_DECLARATOR = 'rule';
2053         my $comment = substr($ORIG, $self->{BEG},100);
2054         $comment =~ s/\n.*//s;
2055         "## $comment\n" . $self->{regex_def}->p5;
2056     }
2057 }
2058
2059
2060 { package VAST::regex_declarator__S_token; our @ISA = 'VAST::Base';
2061     sub emit_p5 {  my $self = shift;
2062         local $::RATCHET = 1;
2063         local $::SIGSPACE = 0;
2064         local $::REGEX_DECLARATOR = 'token';
2065         my $comment = substr($ORIG, $self->{BEG}, 100);
2066         $comment =~ s/\n.*//s;
2067         "## $comment\n" . $self->{regex_def}->p5;
2068     }
2069 }
2070
2071 { package VAST::regex_def; our @ISA = 'VAST::Base';
2072     sub re_ast {  my $self = shift;
2073         RE_ast->new(kind => $::REGEX_DECLARATOR, decl => \@::DECLAST,
2074             re => $self->{regex_block}{nibble}{"."}->re_ast);
2075     }
2076     sub protoregex {  my $self = shift;  my $name = shift;
2077         $::PROTO->{$name} = 1;
2078         $::RETREE->{$name . ":*"} = { dic => $::PKG };
2079         $::PROTOSIG->{$name} = ($self->kids("signature"))[0];
2080         <<EOT;
2081 sub ${name}__PEEK { \$_[0]->_AUTOLEXpeek('$name:*',\$retree); }
2082 sub $name {
2083     my \$self = shift;
2084     my \$subs;
2085
2086     local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2087
2088     my \$C = \$self->cursor_xact('RULE $name');
2089     my \$S = \$C->{'_pos'};
2090
2091     my \@result = do {
2092         my (\$tag, \$try);
2093         my \@try;
2094         my \$relex;
2095         my \$x;
2096         if (my \$fate = \$C->{'_fate'}) {
2097             if (\$fate->[1] eq '$name') {
2098                 \$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
2099                 (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
2100                 \@try = (\$try);
2101                 \$x = 'ALT $name';
2102             }
2103             else {
2104                 \$x = 'ALTLTM $name';
2105             }
2106         }
2107         else {
2108             \$x = 'ALTLTM $name';
2109         }
2110         my \$C = \$C->cursor_xact(\$x);
2111         my \$xact = \$C->{_xact};
2112
2113         my \@gather = ();
2114         for (;;) {
2115             unless (\@try) {
2116                 \$relex //= \$C->cursor_fate('$::PKG', '$name:*', \$retree);
2117                 \@try = \$relex->(\$C) or last;
2118             }
2119             \$try = shift(\@try) // next;
2120
2121             if (ref \$try) {
2122                 (\$C->{'_fate'}, \$tag, \$try) = \@\$try;       # next candidate fate
2123             }
2124
2125             \$C->deb("$name trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
2126             push \@gather, \$C->\$try(\@_);
2127             last if \@gather;
2128             last if \$xact->[-2];  # committed?
2129         }
2130         \$self->_MATCHIFYr(\$S, "$name", \@gather);
2131     };
2132     \@result;
2133 }
2134 EOT
2135     }
2136
2137     sub emit_p5 {  my $self = shift;
2138         my $name = $self->{deflongname}[0]{name}->Str;
2139         $::OVERRIDERX{$name} = 1;
2140         if (defined $::MULTINESS && $::MULTINESS eq 'proto') {
2141             return $self->protoregex($name);
2142         }
2143         my $p5name = $name;
2144         my %adv = $self->{deflongname}[0]->adverbs;
2145         local $::SYM = $adv{sym};
2146         local $::ENDSYM;
2147         local $::REV = '';
2148         local $::PLURALITY = 1;
2149         local @::DECL;
2150         local @::DECLAST;
2151         local $::NEEDORIGARGS = 0;
2152         local $::IGNORECASE = 0;
2153         local $::PAREN = 0;
2154         local %::BINDINGS;
2155
2156         my $spcsig = $self->kids('signature') ?
2157             (($self->kids('signature'))[0])->p5 : '';
2158         my $defsig = $::PROTO && $::PROTOSIG->{$name}
2159             ? $::PROTOSIG->{$name}->p5 : '';
2160         if (defined $adv{sym}) {
2161             $p5name = sprintf "%s__S_%03d%s", $name, $::MULTIRX_SEQUENCE++,
2162                 ::mangle(split " ", $adv{sym});
2163             push @{$::PROTORX_HERE{$name}}, $p5name . "__PEEK";
2164         }
2165         local $::DBA = $name;
2166         local $::DECL_CLASS = $::PKG;
2167         local $::NAME = $p5name;
2168         local $::ALT = 0;
2169         my $ast = $self->re_ast->optimize;
2170
2171         $::RETREE->{$p5name} = $ast;
2172
2173         my $urbody = $ast->walk;
2174         say STDERR "<<< " . $urbody . ": " . $urbody->p5expr if $OPT_log;
2175         my ($body, $ratchet) = $urbody->uncut;
2176         say STDERR "<<< " . $body . ": " . $body->p5expr if $OPT_log;
2177         $ast->{dba_needed} = 1;
2178         $ast->clean;
2179
2180         <<HDR
2181 sub ${p5name}__PEEK { \$_[0]->_AUTOLEXpeek('$p5name', \$retree) }
2182 sub $p5name {
2183 HDR
2184         . ::indent(<<IHDR
2185 no warnings 'recursion';
2186 my \$self = shift;
2187
2188 IHDR
2189         . ($::NEEDORIGARGS ? "    my \@origargs = \@_;\n" : "")
2190         . ::indent($defsig || $spcsig, 1)
2191         . ::indent(join("", @::DECL), 1)
2192         . <<TEXT
2193
2194 local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2195
2196 my \$C = \$self->cursor_xact("RULE $p5name");
2197 my \$xact = \$C->xact;
2198 my \$S = \$C->{'_pos'};
2199 TEXT
2200             . join("", map  { "\$C->{'$_'} = [];\n" }
2201                        grep { $::BINDINGS{$_} > 1 }
2202                        sort keys %::BINDINGS)
2203             . ($::SYM ? '$C->{sym} = "' . ::rd($::SYM) . "\";\n" : '')
2204             . <<END
2205 \$self->_MATCHIFY$ratchet(\$S, "$p5name", ${\ $body->p5expr });
2206 END
2207             , 1) . "}\n";
2208     }
2209 }
2210
2211
2212 { package VAST::Replication; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2213 }
2214
2215
2216 { package VAST::right; our @ISA = 'VAST::Base';
2217 }
2218
2219
2220 { package VAST::routine_declarator; our @ISA = 'VAST::Base';
2221 }
2222
2223
2224 { package VAST::routine_declarator__S_method; our @ISA = 'VAST::Base';
2225     sub emit_p5 {  my $self = shift;
2226         my $comment = substr($ORIG, $self->{BEG},100);
2227         $comment =~ s/\s*\{.*//s;
2228         "## $comment\n" . $self->{method_def}->p5;
2229     }
2230 }
2231
2232
2233 { package VAST::regex_infix; our @ISA = 'VAST::Base';
2234 }
2235
2236 { package VAST::regex_infix__S_Tilde; our @ISA = 'VAST::Base';
2237 }
2238
2239
2240 { package VAST::regex_infix__S_Vert; our @ISA = 'VAST::Base';
2241     sub re_ast {  my $self = shift;
2242         my $altname = $::NAME . "_" . $::ALT++;
2243
2244         RE_any->new(altname => $altname,
2245             zyg => [map { $_->re_ast } $self->kids('args')]);
2246     }
2247 }
2248
2249
2250 { package VAST::regex_infix__S_VertVert; our @ISA = 'VAST::Base';
2251     sub re_ast {  my $self = shift;
2252         RE_first->new(map { $_->re_ast } $self->kids('args'));
2253     }
2254 }
2255
2256
2257 # type erase
2258 { package VAST::scoped; our @ISA = 'VAST::Base';
2259     sub emit_p5 {  my $self = shift;
2260         if (@{$self->{typename}}) {
2261             " " . $self->{multi_declarator}->p5;
2262         } else {
2263             $self->SUPER::emit_p5;
2264         }
2265     }
2266
2267     sub emit_psq {  my $self = shift;  my $scope = shift;
2268         if ($self->{multi_declarator}) {
2269             $self->{multi_declarator}->psq(scope => $scope,
2270                 typename => $self->{typename}[0]->psq);
2271         } elsif ($self->{regex_declarator}) {
2272             $self->{regex_declarator}->psq(scope => $scope);
2273         } elsif ($self->{package_declarator}) {
2274             $self->{package_declarator}->psq(scope => $scope);
2275         } else {
2276             $self->{declarator}->psq(scope => $scope);
2277         }
2278     }
2279 }
2280
2281
2282 { package VAST::scope_declarator; our @ISA = 'VAST::Base';
2283     sub emit_psq { my $self = shift;
2284         $self->{scoped}->psq($self->{SYM});
2285     }
2286 }
2287
2288
2289 { package VAST::scope_declarator__S_has; our @ISA = 'VAST::scope_declarator';
2290     sub emit_p5 {  my $self = shift;
2291         my $scoped = $self->{scoped};
2292         my $typename = $scoped->{typename}[0];
2293         my $multi = $scoped->{multi_declarator};
2294         my $decl = $scoped->{declarator} // $multi->{declarator};
2295         my $vdecl = $decl->{variable_declarator};
2296         my $var = $vdecl->{variable};
2297         "moose_has '" . $var->{desigilname}->Str . "' => (" . join (", ",
2298             ($typename ? ("isa => '" . $typename->Str . "'") : ()),
2299             ("is => 'rw'")
2300         ) . ")";
2301     }
2302 }
2303
2304
2305 { package VAST::scope_declarator__S_my; our @ISA = 'VAST::scope_declarator';
2306     sub emit_p5 {  my $self = shift;
2307         my $t = $self->SUPER::emit_p5;
2308         $t =~ s/my(\s+)&(\w+)/my$1\$$2/;
2309         $t =~ s/my(\s+)([\$@%])::(\w+)/local$1${2}::$3/;
2310         $t;
2311     }
2312 }
2313
2314
2315 { package VAST::scope_declarator__S_our; our @ISA = 'VAST::scope_declarator';
2316 }
2317
2318
2319 { package VAST::semiarglist; our @ISA = 'VAST::Base';
2320 }
2321
2322
2323 { package VAST::semilist; our @ISA = 'VAST::Base';
2324 }
2325
2326
2327 { package VAST::sibble; our @ISA = 'VAST::Base';
2328 }
2329
2330
2331 { package VAST::sigil; our @ISA = 'VAST::Base';
2332     my %psq_hash = ( '$', 'S', '@', 'A', '%', 'H', '&', 'C' );
2333     sub psq_mangle { my $self = shift;
2334         return $psq_hash{$self->{SYM}};
2335     }
2336 }
2337
2338
2339 { package VAST::sigil__S_Amp; our @ISA = 'VAST::sigil';
2340 }
2341
2342
2343 { package VAST::sigil__S_At; our @ISA = 'VAST::sigil';
2344 }
2345
2346
2347 { package VAST::sigil__S_Dollar; our @ISA = 'VAST::sigil';
2348 }
2349
2350
2351 { package VAST::sigil__S_Percent; our @ISA = 'VAST::sigil';
2352 }
2353
2354
2355 { package VAST::sign; our @ISA = 'VAST::Base';
2356 }
2357
2358
2359 { package VAST::signature; our @ISA = 'VAST::Base';
2360     sub emit_p5 { my $self = shift;
2361         for ($self->kids('param_sep')) {
2362             next if $_->{TEXT} =~ /,/;
2363             die "Unusual parameter separators not yet supported";
2364         }
2365
2366         # signature stuff is just parsing code
2367         my @seg = ('', '');
2368         for my $pv ($self->kids('parameter')) {
2369             my ($named, $st) = $pv->p5;
2370             $seg[$named] .= $st . ";\n";
2371         }
2372
2373         if ($seg[1]) { $seg[1] = "my %args = \@_;\n" . $seg[1]; }
2374
2375         $seg[0] . $seg[1];
2376     }
2377 }
2378
2379
2380 { package VAST::spacey; our @ISA = 'VAST::Base';
2381 }
2382
2383
2384
2385 { package VAST::special_variable; our @ISA = 'VAST::Base';
2386 }
2387
2388 { package VAST::special_variable__S_Dollar_a2_; our @ISA = 'VAST::Base';
2389     sub emit_p5 {  my $self = shift;
2390         my @t = $self->SUPER::emit_p5;
2391         $t[0] = '$C';
2392         @t;
2393     }
2394 }
2395
2396
2397 { package VAST::special_variable__S_DollarSlash; our @ISA = 'VAST::Base';
2398     sub emit_p5 {  my $self = shift;
2399         my @t = $self->SUPER::emit_p5;
2400         $t[0] = '$M';
2401         $::NEEDMATCH++;
2402         @t;
2403     }
2404 }
2405
2406
2407 { package VAST::statement; our @ISA = 'VAST::Base';
2408     sub emit_psq {  my $self = shift;
2409         if ($self->{label}) {
2410             return $self->{label}{identifier}->Str . ":\n" .
2411                 $self->{statement}->psq;
2412         }
2413
2414         if ($self->{statement_control}) {
2415             return $self->{statement_control}->psq;
2416         }
2417
2418         return "" if !$self->{EXPR};
2419
2420         my $body = $self->{EXPR}->psq . ";";
2421         for my $m ($self->kids('statement_mod_cond'),
2422                      $self->kids('statement_mod_loop')) {
2423             $body = $m->psq . " {\n" . ::indent($body) . "\n}";
2424         }
2425         $body;
2426     }
2427 }
2428
2429
2430 { package VAST::statement_control; our @ISA = 'VAST::Base';
2431 }
2432
2433
2434 { package VAST::statement_control__S_default; our @ISA = 'VAST::Base';
2435 }
2436
2437
2438 { package VAST::statement_control__S_use; our @ISA = 'VAST::Base';
2439     sub emit_psq { my $self = shift;
2440         $::PRELUDE{$self->{module_name}->Str} = 1;
2441         "";
2442     }
2443 }
2444
2445
2446 { package VAST::statement_control__S_for; our @ISA = 'VAST::Base';
2447 }
2448
2449
2450 { package VAST::statement_control__S_given; our @ISA = 'VAST::Base';
2451 }
2452
2453
2454 { package VAST::statement_control__S_if; our @ISA = 'VAST::Base';
2455     sub emit_p5 {  my $self = shift;
2456         join("\n", ("if " . $self->{xblock}->p5)
2457                  , (map { "elsif " .$_->p5 } @{$self->{elsif}})
2458                  , (map { "else " . $_->p5 } @{$self->{else}}));
2459     }
2460 }
2461
2462
2463 { package VAST::statement_control__S_loop; our @ISA = 'VAST::Base';
2464     sub emit_p5 {  my $self = shift;
2465         my $t = $self->SUPER::emit_p5;
2466         $t =~ s/^loop(\s+\()/for$1/;
2467         $t =~ s/^loop/for (;;)/;
2468         $t;
2469     }
2470 }
2471
2472
2473 { package VAST::statement_control__S_when; our @ISA = 'VAST::Base';
2474     sub emit_p5 {  my $self = shift;
2475         my @t = $self->SUPER::emit_p5;
2476         if ($t[1] =~ s/^\s*\(\s*\*\s*\)//) { $t[0] = 'default'; }
2477         @t;
2478     }
2479 }
2480
2481
2482 { package VAST::statement_control__S_while; our @ISA = 'VAST::Base';
2483 }
2484
2485
2486 { package VAST::statementlist; our @ISA = 'VAST::Base';
2487     sub emit_p5 { my $self = shift;
2488         my @stmts = $self->kids('statement');
2489         # XXX mostly for the benefit of hashes
2490         if (@stmts == 1) {
2491             return $stmts[0]->p5;
2492         }
2493         join("", map { $_->p5 . ";\n" } @stmts);
2494     }
2495     sub emit_psq { my $self = shift;
2496         my @stmts = $self->kids('statement');
2497         local @::LEXVARS;
2498         my $b = join("", map { $_->psq . "\n" } @stmts);
2499         join("", @::LEXVARS, $b);
2500     }
2501 }
2502
2503
2504 { package VAST::statement_mod_cond; our @ISA = 'VAST::Base';
2505 }
2506
2507
2508 { package VAST::statement_mod_cond__S_if; our @ISA = 'VAST::Base';
2509 }
2510
2511
2512 { package VAST::statement_mod_cond__S_unless; our @ISA = 'VAST::Base';
2513 }
2514
2515
2516 { package VAST::statement_mod_loop; our @ISA = 'VAST::Base';
2517 }
2518
2519
2520 { package VAST::statement_mod_loop__S_for; our @ISA = 'VAST::Base';
2521 }
2522
2523
2524 { package VAST::statement_mod_loop__S_while; our @ISA = 'VAST::Base';
2525 }
2526
2527
2528 { package VAST::statement_prefix; our @ISA = 'VAST::Base';
2529 }
2530
2531
2532 { package VAST::statement_prefix__S_do; our @ISA = 'VAST::Base';
2533 }
2534
2535
2536 { package VAST::statement_prefix__S_try; our @ISA = 'VAST::Base';
2537     sub emit_p5 {  my $self = shift;
2538         my @t = $self->SUPER::emit_p5;
2539         $t[0] = 'eval';
2540         @t;
2541     }
2542 }
2543
2544
2545 { package VAST::stdstopper; our @ISA = 'VAST::Base';
2546 }
2547
2548
2549 { package VAST::stopper; our @ISA = 'VAST::Base';
2550 }
2551
2552
2553 { package VAST::Structural_infix; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2554 }
2555
2556
2557 { package VAST::sublongname; our @ISA = 'VAST::Base';
2558 }
2559
2560
2561 { package VAST::subshortname; our @ISA = 'VAST::Base';
2562 }
2563
2564
2565 { package VAST::Symbolic_unary; our @ISA = 'VAST::Base';
2566 }
2567
2568
2569 { package VAST::term; our @ISA = 'VAST::Base';
2570 }
2571
2572 { package VAST::term__S_capterm; our @ISA = 'VAST::Base';
2573 }
2574
2575
2576 { package VAST::term__S_circumfix; our @ISA = 'VAST::Base';
2577 }
2578
2579
2580 { package VAST::term__S_colonpair; our @ISA = 'VAST::Base';
2581     sub emit_p5 {  my $self = shift;
2582         my $t = $self->SUPER::emit_p5;
2583         my $val;
2584         if ($t =~ s/^:!//) {
2585             $val = 0
2586         }
2587         elsif ($t =~ s/^:(\d+)//) {
2588             $val = $1;
2589         }
2590         else {
2591             $t =~ s/^://;
2592             $val = 1;
2593         }
2594         if ($t =~ s/^(\w+)$/'$1'/) {
2595             $t .= " => $val";
2596         }
2597         else {
2598             my ($name,$rest) = $t =~ /^(\w+)(.*)$/s;
2599             $rest =~ s/^<([^\s']*)>/'$1'/ or
2600             $rest =~ s/^(<\S*>)/q$1/ or
2601             $rest =~ s/^(<\s*\S+\s*>)/qw$1/ or
2602             $rest =~ s/^(<.*>)/[qw$1]/; # p5's => isn't scalar context
2603             $t = "'$name' => $rest";
2604         }
2605         $t;
2606     }
2607
2608 }
2609
2610
2611 { package VAST::term__S_fatarrow; our @ISA = 'VAST::Base';
2612 }
2613
2614
2615 { package VAST::term__S_identifier; our @ISA = ('VAST::ViaDEEP', 'VAST::Base');
2616     sub emit_p5 {  my $self = shift;
2617         my @t = $self->SUPER::emit_p5;
2618         if ($t[0] eq 'item') {
2619             $t[0] = '\\';
2620             $t[1] =~ s/^\s+//;
2621         }
2622         if ($t[0] eq 'map' || $t[0] eq 'grep' || $t[0] eq 'sort') {
2623             # XXX this should be more robust, but it belongs in DEEP after
2624             # all arguments are collected anyway
2625             $t[1] =~ s/}\s*,/} /;
2626         }
2627         if ($t[0] eq 'invert') {
2628             $t[0] = 'reverse';
2629         }
2630         if ($t[0] eq 'chars') {
2631             $t[0] = 'length';
2632         }
2633         if ($t[0] eq 'note') {
2634             $t[0] = 'print STDERR';
2635         }
2636         if ($t[0] eq 'False') {
2637             $t[0] = '0';
2638         }
2639         if ($t[0] eq 'True') {
2640             $t[0] = '1';
2641         }
2642         if ($t[0] eq 'Nil') {
2643             $t[0] = '()';
2644         }
2645         @t;
2646     }
2647
2648     sub _deep { my $self = shift;
2649         my $id = $self->{identifier}->Str;
2650         my @args = $self->{args}->deepn;
2651
2652         DEEP::call($id, @args);
2653     }
2654 }
2655
2656
2657 { package VAST::term__S_multi_declarator; our @ISA = 'VAST::Base';
2658 }
2659
2660
2661 { package VAST::term__S_package_declarator; our @ISA = 'VAST::Base';
2662     sub emit_psq { $_[0]{package_declarator}->psq }
2663 }
2664
2665
2666 { package VAST::term__S_regex_declarator; our @ISA = 'VAST::Base';
2667     sub emit_p5 {  my $self = shift;;
2668         $self->{regex_declarator}->p5;
2669     }
2670 }
2671
2672
2673 { package VAST::term__S_routine_declarator; our @ISA = 'VAST::Base';
2674 }
2675
2676
2677 { package VAST::term__S_scope_declarator; our @ISA = 'VAST::Base';
2678     sub emit_psq {  my $self = shift;
2679         $self->{scope_declarator}->psq;
2680     }
2681 }
2682
2683
2684 { package VAST::term__S_statement_prefix; our @ISA = 'VAST::Base';
2685 }
2686
2687
2688 { package VAST::term__S_term; our @ISA = 'VAST::Base';
2689 }
2690
2691
2692 { package VAST::term__S_value; our @ISA = 'VAST::Base';
2693     sub emit_psq { $_[0]{value}->psq}
2694 }
2695
2696
2697 { package VAST::term__S_variable; our @ISA = 'VAST::Base';
2698 }
2699
2700
2701 { package VAST::terminator; our @ISA = 'VAST::Base';
2702     sub emit_p6 {  my $self = shift;
2703         my @t = $self->SUPER::emit_p6;
2704         '';
2705     }
2706 }
2707
2708 { package VAST::terminator__S_BangBang; our @ISA = 'VAST::terminator'; }
2709
2710 { package VAST::terminator__S_for; our @ISA = 'VAST::terminator'; }
2711
2712 { package VAST::terminator__S_if; our @ISA = 'VAST::terminator'; }
2713
2714 { package VAST::terminator__S_Ket; our @ISA = 'VAST::terminator'; }
2715
2716 { package VAST::terminator__S_Ly; our @ISA = 'VAST::terminator'; }
2717
2718 { package VAST::terminator__S_Semi; our @ISA = 'VAST::terminator'; }
2719
2720 { package VAST::terminator__S_Thesis; our @ISA = 'VAST::terminator'; }
2721
2722 { package VAST::terminator__S_unless; our @ISA = 'VAST::terminator'; }
2723
2724 { package VAST::terminator__S_while; our @ISA = 'VAST::terminator'; }
2725
2726 { package VAST::terminator__S_when; our @ISA = 'VAST::terminator'; }
2727
2728
2729 { package VAST::termish; our @ISA = 'VAST::Base';
2730 }
2731
2732
2733
2734 { package VAST::term; our @ISA = 'VAST::Base';
2735 }
2736
2737 { package VAST::term__S_name; our @ISA = ('VAST::Base');
2738     sub emit_p5 {  my $self = shift;
2739         my @t = $self->SUPER::emit_p5;
2740         if (my ($pkg) = ($t[0] =~ /^::(.*)/)) {
2741             $pkg = $::OUR{$pkg} // $pkg;
2742             if (defined $t[1] && $t[1] =~ /^\s*\[/) {
2743                 $t[1] =~ s/^\s*\[/->__instantiate__(/;
2744                 $t[1] =~ s/\]\s*$/)/;
2745                 $t[0] = "$pkg";
2746             } else {
2747                 $t[0] = "'$pkg'";
2748             }
2749         }
2750         @t;
2751     }
2752 }
2753
2754
2755 { package VAST::term__S_self; our @ISA = 'VAST::Base';
2756     sub emit_p5 {  my $self = shift;
2757         my @t = $self->SUPER::emit_p5;
2758         $t[0] = '$self';
2759         @t;
2760     }
2761 }
2762
2763
2764 { package VAST::term__S_Star; our @ISA = 'VAST::Base';
2765 }
2766
2767
2768 { package VAST::term__S_undef; our @ISA = 'VAST::Base';
2769 }
2770
2771
2772 { package VAST::Tight_or; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2773 }
2774
2775 { package VAST::Tight_and; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2776 }
2777
2778
2779 { package VAST::trait; our @ISA = 'VAST::Base';
2780 }
2781
2782
2783 { package VAST::trait_auxiliary; our @ISA = 'VAST::Base';
2784 }
2785
2786
2787 { package VAST::trait_auxiliary__S_does; our @ISA = 'VAST::Base';
2788 }
2789
2790
2791 { package VAST::trait_auxiliary__S_is; our @ISA = 'VAST::Base';
2792 }
2793
2794
2795
2796 { package VAST::twigil; our @ISA = 'VAST::Base';
2797 }
2798
2799 { package VAST::twigil__S_Dot; our @ISA = 'VAST::Base';
2800     sub emit_p5 {  my $self = shift;
2801         my @t = $self->SUPER::emit_p5;
2802         $t[0] = 'self->';       # XXX
2803         @t;
2804     }
2805 }
2806
2807
2808 { package VAST::twigil__S_Star; our @ISA = 'VAST::Base';
2809     sub emit_p5 {  my $self = shift;
2810         my @t = $self->SUPER::emit_p5;
2811         $t[0] = '::';
2812         @t;
2813     }
2814 }
2815
2816 { package VAST::twigil__S_Caret; our @ISA = 'VAST::Base';
2817     sub emit_p5 {  my $self = shift;
2818         my @t = $self->SUPER::emit_p5;
2819         $t[0] = ''; #XXX only correct for sorts
2820         @t;
2821     }
2822 }
2823
2824
2825 { package VAST::type_constraint; our @ISA = 'VAST::Base';
2826 }
2827
2828 { package VAST::type_declarator__S_constant; our @ISA = 'VAST::Base';
2829     sub emit_p5 {  my $self = shift;
2830         my $t = $self->SUPER::emit_p5;
2831         $t =~ s/constant/our/;
2832         $t;
2833     }
2834 }
2835
2836
2837
2838 { package VAST::typename; our @ISA = 'VAST::Base';
2839     sub emit_p5 {  my $self = shift;
2840         my @t;
2841         if (ref $context[-1] ne 'VAST::scoped') {
2842             @t = $self->SUPER::emit_p5;
2843         }
2844         @t;
2845     }
2846
2847     sub emit_psq { my $self = shift;
2848         my $s = $self->Str;
2849         $s eq 'Str' &&           return 'str';
2850         $s eq 'Int' &&           return 'int';
2851         $s;
2852     }
2853 }
2854
2855
2856 { package VAST::unitstopper; our @ISA = 'VAST::Base';
2857 }
2858
2859
2860 { package VAST::unspacey; our @ISA = 'VAST::Base';
2861 }
2862
2863
2864 { package VAST::unv; our @ISA = 'VAST::Base';
2865 }
2866
2867
2868 { package VAST::val; our @ISA = 'VAST::Base';
2869 }
2870
2871
2872 { package VAST::value; our @ISA = 'VAST::Base';
2873 }
2874
2875
2876 { package VAST::value__S_number; our @ISA = 'VAST::Base';
2877     sub emit_psq { $_[0]{number}->psq}
2878 }
2879
2880
2881 { package VAST::value__S_quote; our @ISA = 'VAST::Base';
2882     sub emit_psq { $_[0]{quote}->psq}
2883 }
2884
2885
2886 { package VAST::variable; our @ISA = 'VAST::Base';
2887     sub emit_p5 { my $self = shift;
2888         my @t = $self->SUPER::emit_p5;
2889         if (@t >= 2) { # $t[0] eq '$' but XXX STD uses %<O><prec> (erroneously?)
2890             if ($t[1] =~ /^\d+$/) {
2891                 $t[1] = "M->{$t[1]}";
2892                 $::NEEDMATCH = 1;
2893             } elsif ($t[1] =~ /^{/) {
2894                 $t[0] = "\$M->";
2895                 $::NEEDMATCH = 1;
2896             }
2897         }
2898         @t;
2899     }
2900
2901     sub emit_psq { my $self = shift;
2902         return '$' . $self->{sigil}->psq_mangle . '_' . $self->{desigilname}->Str;
2903     }
2904 }
2905
2906
2907 { package VAST::variable_declarator; our @ISA = 'VAST::Base';
2908     sub emit_psq { my $self = shift; my %args = @_;
2909         my $scope = $args{scope};
2910         my $type  = $args{typename};
2911         my $var   = $self->{variable}->psq;
2912         my $s     = $self->{variable}{sigil}{SYM};
2913
2914         if ($scope eq 'my') {
2915             die "Variables in Perlesque *must* be typed" unless $type;
2916             push @::LEXVARS, "my $type $var;\n" if $s eq '$';
2917             push @::LEXVARS, "my List[$type] $var = List[$type].new();\n"
2918                 if $s eq '@';
2919             push @::LEXVARS, "my Dictionary[str,$type] $var = Dictionary[str,$type].new();\n" if $s eq '%';
2920             return $var;
2921         }
2922     }
2923 }
2924
2925
2926 { package VAST::vws; our @ISA = 'VAST::Base';
2927 }
2928
2929
2930 { package VAST::ws; our @ISA = 'VAST::Base';
2931 }
2932
2933
2934
2935 { package VAST::xblock; our @ISA = 'VAST::Base';
2936     sub emit_p5 {  my $self = shift;
2937         my @t = $self->SUPER::emit_p5;
2938         $t[0] = '(' . $t[0] . ')';
2939         $t[0] =~ s/(\s+)\)$/)$1/;
2940         @t;
2941     }
2942 }
2943
2944 { package VAST::XXX; our @ISA = 'VAST::Base';
2945 }
2946
2947 { package REbase;
2948     sub kids { }
2949     sub clone {
2950         my $self = shift;
2951         my $dopp = bless { %$self }, ref($self);
2952         for my $dkid ($dopp->kids) {
2953             $$dkid = $$dkid->clone;
2954         }
2955         $dopp;
2956     }
2957     sub new {  my $class = shift;
2958         my $self = bless { a => 0, i => $::IGNORECASE ? 1 : 0,
2959             r => $::RATCHET ? 1 : 0, s => $::SIGSPACE ? 1 : 0,
2960             dba => $::DBA, dic => $::DECL_CLASS, @_ }, $class;
2961         $self;
2962     }
2963
2964     sub optimize { my $self = shift;
2965         for my $kid ($self->kids) {
2966             $$kid = $$kid->optimize;
2967         }
2968         $self;
2969     }
2970
2971     sub clean { my $self = shift;
2972         for my $kid ($self->kids) {
2973             $$kid->clean;
2974         }
2975         delete $self->{r};
2976         delete $self->{s};
2977         delete $self->{a};
2978         delete $self->{i} unless $self->{i_needed};
2979         delete $self->{i_needed};
2980         delete $self->{dba} unless $self->{dba_needed};
2981         delete $self->{dic} unless $self->{dba_needed};
2982         delete $self->{dba_needed};
2983     }
2984
2985     sub walk {  my $self = shift;
2986         say STDERR "--> $self" if $OPT_log;
2987         my $exp = $self->_walk;
2988         if ($self->{r} && $exp->maybacktrack) {
2989             $exp = DEEP::cut($exp);
2990         }
2991         say STDERR "<-- $exp: ", $exp->p5expr if $OPT_log;
2992         $exp;
2993     }
2994
2995     sub _walk {
2996         my $self = shift;
2997         my $result = "";
2998         if ($$self{zyg}) {
2999             foreach my $kid (@{$$self{zyg}}) {
3000                 my $x = $kid->walk->p5;
3001                 $result .= $x if defined $x;
3002             }
3003         }
3004         else {
3005             return ref $self;
3006         }
3007         return DEEP::raw($result);
3008     }
3009
3010     sub bind { my $self = shift; my $re = shift;
3011         return $re unless @_;
3012         DEEP::bind($re, @_);
3013     }
3014
3015     sub remove_leading_ws { }   # this tree node not interested
3016     sub has_trailing_ws { 0 }
3017 }
3018
3019 { package RE_double; use base "REbase";
3020     sub _walk {
3021         my $self = shift;
3022         my $text = $$self{text};
3023         $$self{i_needed} = 1;
3024         # XXX needs interpolation
3025         if ($$self{i}) {
3026             $text = $::REV ? "(?<=" . ::rd($text) . ")" : ::rd($text);
3027             DEEP::raw('$C->_PATTERN(qr/\\G(?i:' . $text . ')/")', precut => 1);
3028         }
3029         else {
3030             DEEP::raw("\$C->_EXACT(\"" . ::rd($text) . "\")", precut => 1);
3031         }
3032     }
3033 }
3034
3035 { package RE_string; use base "REbase";
3036     sub _walk {
3037         my $self = shift;
3038         $$self{i_needed} = 1;
3039         my $text = ::rd($$self{text});
3040         $text = "(?<=$text)" if $::REV;
3041         $text = "(?i:$text)" if $$self{i};
3042         DEEP::p5regex($text, has_meta => ($::REV || $$self{i}),
3043             needs_bracket => !($::REV || $$self{i}) && (length($$self{text}) != 1));
3044     }
3045 }
3046
3047 { package RE_sequence;
3048     sub new {
3049         my ($class, @zyg) = @_;
3050         $class->SUPER::new(zyg => \@zyg);
3051     }
3052
3053     sub wrapone {
3054         my ($self, $outer, $inner) = @_;
3055         my ($out1, $outr) = $outer->uncut;
3056         if ($outr) {
3057             DEEP::ratchet($inner, $out1);
3058         } else {
3059             DEEP::raw(::hang("LazyMap::lazymap(" . DEEP::chunk($inner)->p5expr .
3060                 ",\n" . $outer->p5expr . ")", "    "));
3061         }
3062     }
3063
3064     sub _walk {
3065         my $self = shift;
3066         my @result;
3067         my @decl;
3068         if ($$self{zyg}) {
3069             my @kids = @{$$self{zyg}};
3070             my @ckids;
3071
3072             while (@kids and ref $kids[0] eq 'RE_decl') {
3073                 push @decl, shift(@kids)->walk->p5block;
3074             }
3075
3076             @kids = map { $_->walk } @kids;
3077
3078             while (@kids) {
3079                 my $rx = '';
3080                 my $hm = 0;
3081
3082                 while (@kids && $kids[0]->isa('DEEP::p5regex')) {
3083                     my $rk = shift(@kids);
3084                     $rx .= $rk->cutre(0);
3085                     $hm ||= $rk->{has_meta};
3086                 }
3087
3088                 if ($rx ne '') {
3089                     push @ckids, DEEP::p5regex($rx, needs_bracket => 1,
3090                         has_meta => $hm);
3091                 }
3092
3093                 if (@kids) {
3094                     push @ckids, shift(@kids);
3095                 }
3096             }
3097
3098             @ckids = reverse @ckids if $::REV;
3099             @result = @ckids;
3100         }
3101         my $result = pop @result;
3102         for (reverse @result) {
3103             $result = $self->wrapone($_,$result);
3104         }
3105         @decl ?
3106             DEEP::raw(join('', @decl, $result ? $result->p5expr . "\n" : ''), isblock => 1) :
3107             $result // DEEP::raw('', isblock => 1);
3108     }
3109
3110     sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
3111
3112     sub optimize { my $self = shift;
3113         my @ok;
3114
3115         my $afterspace = 0;
3116         for my $kid ($self->kids) {
3117             $$kid->remove_leading_ws if $afterspace;
3118             $afterspace = $$kid->has_trailing_ws($afterspace);
3119         }
3120
3121         $self = $self->SUPER::optimize;
3122
3123         for my $k (@{$self->{zyg}}) {
3124             next if $k->isa('RE_noop');
3125             if ($k->isa('RE_sequence')) {
3126                 push @ok, @{$k->{zyg}};
3127             } else {
3128                 push @ok, $k;
3129             }
3130         }
3131
3132         return RE_noop->new if @ok == 0;
3133         return $ok[0] if @ok == 1;
3134         $self->{zyg} = \@ok;
3135         $self;
3136     }
3137
3138     sub remove_leading_ws {
3139         my $self = shift;
3140
3141         for my $kid ($self->kids) {
3142             my $l = $$kid->has_trailing_ws(1);
3143             $$kid->remove_leading_ws;
3144             last unless $l;
3145         }
3146     }
3147
3148     sub has_trailing_ws {
3149         my $self = shift;
3150         my $before = shift;
3151
3152         for my $kid ($self->kids) {
3153             $before = $$kid->has_trailing_ws($before);
3154         }
3155
3156         $before;
3157     }
3158 }
3159
3160 { package RE_any; use base "REbase";
3161     sub _walk {
3162         my $self = shift;
3163         my @result;
3164         my $alt = 0;
3165         my $altname = $self->{altname};
3166         if ($$self{zyg}) {
3167             my %B = %::BINDINGS;
3168             for my $kid (@{$$self{zyg}}) {
3169                 local %::BINDINGS;
3170                 my $r = $kid->walk;
3171                 for my $b (keys %::BINDINGS) {
3172                     $B{$b} = 2 if $::BINDINGS{$b} > 1 or $B{$b};
3173                 }
3174                 push @result, $r;
3175                 $kid->{alt} = $altname . ' ' . $alt++;
3176             }
3177             %::BINDINGS = %B;
3178         }
3179         if (@result == 1) {
3180             $result[0];
3181         }
3182         else {
3183             $::RETREE->{$self->{altname}} = $self;
3184             $self->{dba_needed} = 1;
3185             my $result = <<"END";
3186 do {
3187     my (\$tag, \$try);
3188     my \@try;
3189     my \$relex;
3190
3191     my \$fate;
3192     my \$x;
3193     if (\$fate = \$C->{'_fate'} and \$fate->[1] eq '$altname') {
3194         \$C->deb("Fate passed to $altname: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
3195         (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
3196         \@try = (\$try);
3197         \$x = 'ALT $altname';    # some outer ltm is controlling us
3198     }
3199     else {
3200         \$x = 'ALTLTM $altname'; # we are top level ltm
3201     }
3202     my \$C = \$C->cursor_xact(\$x);
3203     my \$xact = \$C->{_xact};
3204
3205     my \@gather = ();
3206     for (;;) {
3207         unless (\@try) {
3208             \$relex //= \$C->cursor_fate('$::PKG', '$altname', \$retree);
3209             \@try = \$relex->(\$C) or last;
3210         }
3211         \$try = shift(\@try) // next;
3212
3213         if (ref \$try) {
3214             (\$C->{'_fate'}, \$tag, \$try) = \@\$try;   # next candidate fate
3215         }
3216
3217         \$C->deb("$altname trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
3218         push \@gather, ((
3219 END
3220                 for my $i (0 .. @result - 1) {
3221                     $result .= ::indent(DEEP::chunk($result[$i])->p5expr, 3);
3222                     if ($i != @result - 1) {
3223                         $result .= ",";
3224                     }
3225                     $result .= "\n";
3226                 }
3227                 $result .= <<END;
3228         )[\$try])->(\$C);
3229         last if \@gather;
3230         last if \$xact->[-2];  # committed?
3231     }
3232     \@gather;
3233 };
3234 END
3235             DEEP::raw($result, isblock => 1);
3236         }
3237     }
3238
3239     sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
3240
3241     sub optimize { my $self = shift()->SUPER::optimize;
3242         my @ok;
3243
3244         for my $k (@{$self->{zyg}}) {
3245             if ($k->isa('RE_any')) {
3246                 push @ok, @{$k->{zyg}};
3247             } else {
3248                 push @ok, $k;
3249             }
3250         }
3251
3252         return $ok[0] if @ok == 1;
3253         $self->{zyg} = \@ok;
3254         $self;
3255     }
3256
3257     # yes, this affects LTM, but S05 specs it
3258     sub remove_leading_ws {
3259         my $self = shift;
3260         for my $kid (@{$$self{zyg}}) {
3261             $kid->remove_leading_ws();
3262         }
3263     }
3264
3265     sub has_trailing_ws {
3266         my $self = shift;
3267         my $before = shift;
3268         my $after = 1;
3269
3270         for my $kid ($self->kids) {
3271             $after &&= $$kid->has_trailing_ws($before);
3272         }
3273
3274         $after;
3275     }
3276 }
3277
3278 { package RE_first; use base "REbase";
3279     sub new {
3280         my ($class, @zyg) = @_;
3281         $class->SUPER::new(zyg => \@zyg);
3282     }
3283
3284     sub _walk {
3285         my $self = shift;
3286         my @result;
3287         if ($$self{zyg}) {
3288             my %B = %::BINDINGS;
3289             foreach my $kid (@{$$self{zyg}}) {
3290                 local %::BINDINGS;
3291                 push @result, $kid->walk->p5expr;
3292                 for my $b (keys %::BINDINGS) {
3293                     $B{$b} = 2 if $::BINDINGS{$b} > 1 or $B{$b};
3294                 }
3295             }
3296             %::BINDINGS = %B;
3297         }
3298         if (@result == 1) {
3299             DEEP::raw($result[0]);
3300         }
3301         else {
3302             die("Can't reverse serial disjunction") if $::REV;
3303             for (@result) { $_ = "do {\n" . ::indent("push \@gather, $_\n") . "}"; }
3304             # We need to force the scope here because of the my $C
3305             my $result = "do {" . ::indent(
3306                 "my \$C = \$C->cursor_xact('ALT ||');\n" .
3307                 "my \$xact = \$C->xact;\nmy \@gather;\n" .
3308                 join("\nor \$xact->[-2] or\n", @result) . ";\n" .
3309                 "\@gather;\n") . "}";
3310             DEEP::raw($result);
3311         }
3312     }
3313
3314     sub kids { my $self = shift; map { \$_ } @{$self->{zyg}} }
3315
3316     sub remove_leading_ws {
3317         my $self = shift;
3318         for my $kid (@{$$self{zyg}}) {
3319             $kid->remove_leading_ws();
3320         }
3321     }
3322
3323     sub has_trailing_ws {
3324         my $self = shift;
3325         my $before = shift;
3326         my $after = 1;
3327
3328         for my $kid ($self->kids) {
3329             $after &&= $$kid->has_trailing_ws($before);
3330         }
3331
3332         $after;
3333     }
3334 }
3335
3336 { package RE_method; use base "REbase";
3337     sub clean { my $self = shift;
3338         $self->SUPER::clean;
3339         delete $self->{nobind};
3340         delete $self->{need_match};
3341         $self->{rest} = defined $self->{rest};
3342     }
3343     sub _walk {
3344         my $self = shift;
3345         local $::NEEDMATCH = 0;
3346         my $name = $$self{name};
3347         die "Can't reverse $name" if $::REV;
3348         my $re;
3349
3350         if ($name eq "sym") {
3351             $$self{i_needed} = 1;
3352             $$self{sym} = $::SYM;
3353             $$self{endsym} = $::ENDSYM if defined $::ENDSYM;
3354             if ($$self{i}) {
3355                 return DEEP::p5regex("(?i:" . ::rd($::SYM) . ")");
3356             }
3357             else {
3358                 return DEEP::p5regex(::rd($::SYM), has_meta => 0);
3359             }
3360         }
3361         elsif ($name eq "alpha") {
3362             return DEEP::p5regex("[_[:alpha:]]");
3363         }
3364         elsif ($name eq "_ALNUM") {
3365             return DEEP::p5regex("\\w");
3366         }
3367         elsif ($name eq "nextsame") {
3368             $::NEEDORIGARGS++;
3369             $re = '$self->SUPER::' . $::NAME . '(@origargs)';
3370         }
3371         elsif ($name =~ /^\w/) {
3372             my $al = $self->{rest} // '';
3373             $re = '$C->' . $name . $al;
3374         }
3375         else {
3376             my $al = $self->{rest} // '';
3377             $re = <<"END";
3378 do {
3379   if (not $name) {
3380     \$C;
3381   }
3382   elsif (ref $name eq 'Regexp') {
3383     if (\$::ORIG =~ m/$name/gc) {
3384       \$C->cursor(\$+[0]);
3385     }
3386     else {
3387       ();
3388     }
3389   }
3390   else {
3391     \$C->$name$al;
3392   }
3393 }
3394 END
3395         }
3396         $re = "do {\n" . ::indent("my \$M = \$C;\n$re") . "\n}" if $self->{need_match};
3397         $re = DEEP::raw($re);
3398         if ($name =~ /^\w/ and not $self->{nobind}) {
3399             $::BINDINGS{$name} += $::PLURALITY;
3400             $re = $self->bind($re, $name);
3401         }
3402         $re;
3403     }
3404
3405     sub has_trailing_ws {
3406         my $self = shift;
3407         return $self->{name} eq 'ws';
3408     }
3409
3410     sub remove_leading_ws {
3411         my $self = shift;
3412         if ($self->{name} eq 'ws' && $self->{nobind}) {
3413             bless $self, 'RE_noop';
3414         }
3415     }
3416 }
3417
3418 { package RE_ast; use base "REbase";
3419     sub clean { my $self = shift;
3420         $self->SUPER::clean;
3421         delete $self->{decl};
3422         delete $self->{kind};
3423     }
3424     sub _walk {
3425         my $self = shift;
3426         if ($$self{decl}) {
3427             for my $decl (@{$$self{decl}}) {
3428                 push @::DECL, $decl->walk->p5block;
3429             }
3430         }
3431         if ($$self{re}) {
3432             $$self{re}->walk;
3433         }
3434     }
3435
3436     sub kids { my $self = shift; \$self->{re}, map { \$_ } @{$self->{decl}}; }
3437 }
3438
3439 { package RE_quantified_atom; use base "REbase";
3440     # handles cutting itself
3441     sub clean { my $self = shift;
3442         $self->SUPER::clean;
3443         splice @{$self->{quant}}, ($self->{quant}[0] eq '**' ? 3 : 1);
3444     }
3445     sub _walk {
3446         my $self = shift;
3447         my $result;
3448         local $::PLURALITY = 2;
3449         my $quant = "";
3450         my $rep = "_REP";
3451         my $q = $$self{quant};
3452         my $bind = $::BINDINSIDE;
3453         undef $::BINDINSIDE;
3454         my $atom = $$self{atom}->walk;
3455         if ($bind) { #XXX STD
3456             $atom = $self->bind($atom, $bind);
3457         }
3458         my $atom_is_cut = !$atom->maybacktrack;
3459         my ($qfer,$how,$rest) = @{$$self{quant}};
3460         my $hc = $how eq '!' ? 'g' :
3461                  $how eq '?' ? 'f' :
3462                                'r';
3463         my $hr = $how eq '!' ? '' :
3464                  $how eq '?' ? '?' :
3465                                '+';
3466         if ($atom->isa('DEEP::p5regex') && $hc eq 'r' && !$::REV && $qfer ne '**') {
3467             return DEEP::p5regex($atom->cutre(1) . "$qfer$hr", needs_bracket => 1);
3468         }
3469
3470         if ($qfer eq '*') {
3471             $quant = "\$C->_STAR$hc$::REV(";
3472         }
3473         elsif ($qfer eq '+') {
3474             $quant = "\$C->_PLUS$hc$::REV(";
3475         }
3476         elsif ($qfer eq '?') {
3477             $quant = "\$C->_OPT$hc$::REV(";
3478         }
3479         elsif ($qfer eq '**') {
3480             if (ref $rest) {
3481                 if (ref $rest eq "RE_block") {
3482                     $rep = "_REPINDIRECT$::REV";
3483                     $rest = $rest->walk;
3484                 }
3485                 else {
3486                     $rep = "_REPSEP$::REV";
3487                     $rest = DEEP::chunk($rest->walk)->p5expr;
3488                 }
3489             }
3490             else {
3491                 $rest = "'$rest'";
3492             }
3493             $quant = "\$C->$rep$hc( $rest, ";
3494         }
3495         return DEEP::raw($quant . ::hang(DEEP::chunk($atom)->p5expr, "    ") . ")", precut => ($hc eq 'r'));
3496     }
3497
3498     sub kids { my $self = shift; \$self->{atom} }
3499
3500     sub optimize {
3501         my $self = shift()->SUPER::optimize;
3502         if ($self->{quant}[0] eq '*' &&
3503                 $self->{quant}[1] ne ':' &&
3504                 $self->{atom}->isa('RE_meta') &&
3505                 $self->{atom}{text} eq '.') {
3506             delete $self->{atom};
3507             $self->{text} = ($self->{quant}[1] eq '?') ? '.*?' : '.*';
3508             delete $self->{quant};
3509             bless $self, 'RE_meta';
3510         }
3511         $self;
3512     }
3513 }
3514
3515 { package RE_qw; use base "REbase";
3516     sub _walk {
3517         my $self = shift;
3518         DEEP::raw("\$C->_ARRAY$::REV( qw$$self{text} )");
3519     }
3520 }
3521
3522 { package RE_method_re; use base "REbase";
3523     sub _walk {
3524         my $self = shift;
3525         my $re = $$self{re};
3526         my $name = $$self{name};
3527         die("Can't reverse $name") if $::REV and $name ne 'before';
3528         local $::REV = $name eq 'after' ? '_rev' : '';
3529         {
3530             local %::BINDINGS;
3531             $re = $re->walk->p5block;
3532             if (%::BINDINGS) {
3533                 for my $binding ( keys %::BINDINGS ) {
3534                     next unless $::BINDINGS{$binding} > 1;
3535                     $re = <<"END" . $re;
3536 \$C->{'$binding'} = [];
3537 END
3538                 }
3539             }
3540         }
3541         $::REV = '';
3542
3543         $re = DEEP::raw('$C->' . $name . "(" . ::hang(DEEP::chunk(DEEP::raw($re, isblock => 1))->p5expr, "    ") . ")");
3544         if ($name =~ /^\w/ and not $self->{nobind}) {
3545             $re = $self->bind($re, $name);
3546             $::BINDINGS{$name} += $::PLURALITY;
3547         }
3548         $re;
3549     }
3550
3551     sub kids { my $self = shift; \$self->{re} }
3552 }
3553
3554 { package RE_assertion; use base "REbase";
3555     sub _walk {
3556         my $self = shift;
3557         if ($$self{assert} eq '!') {
3558             my $re = $$self{re}->walk;
3559             DEEP::raw("\$C->_NOTBEFORE(" . ::hang(DEEP::chunk($re)->p5expr, "    ") .")");
3560         }
3561         else {
3562             my $re = $$self{re}->walk;
3563             return $re if $re->p5expr =~ /^\$C->before/; #XXX
3564             DEEP::raw("\$C->before(" . ::hang(DEEP::chunk($re)->p5expr, "    ") . ")");
3565         }
3566     }
3567     # TODO: Investigate what the LTM engine is doing with assertions and
3568     # optimize harder.
3569
3570     sub has_trailing_ws {
3571         my $self = shift;
3572         my $before = shift;
3573
3574         $before; # Transparent
3575     }
3576
3577     sub remove_leading_ws {
3578         my $self = shift;
3579
3580         $self->{re}->remove_leading_ws;
3581     }
3582
3583     sub kids { my $self = shift; \$self->{re} }
3584 }
3585
3586 { package RE_meta; use base "REbase";
3587     sub _walk {
3588         my $self = shift;
3589         my $text = $$self{text};
3590         my $not = 0;
3591         my $code = "";
3592         my $bt = 0;
3593         if ($text =~ /^(\\[A-Z])(.*)/) {
3594             $text = lc($1) . $2;
3595             $not = 1;
3596         }
3597         # to return yourself, you must either be a symbol or handle $not
3598         if ($text eq '.') {
3599             if ($::REV) {
3600                 return DEEP::p5regex("(?<=(?s:.)");
3601             }
3602             else {
3603                 $code = "\$C->cursor_incr()";
3604             }
3605         }
3606         elsif ($text eq '.*') {
3607             $code = "\$C->_SCANg$::REV()";
3608             $bt = 1;
3609         }
3610         elsif ($text eq '.*?') {
3611             $code = "\$C->_SCANf$::REV()";
3612             $bt = 1;
3613         }
3614         elsif ($text eq '^') {
3615             return DEEP::p5regex('\A');
3616         }
3617         elsif ($text eq '^^') {
3618             return DEEP::p5regex('(?m:^)');
3619         }
3620         elsif ($text eq '$') {
3621             return DEEP::p5regex('\z');
3622         }
3623         elsif ($text eq '$$') {
3624             return DEEP::p5regex('(?m:$)');
3625         }
3626         elsif ($text eq ':') {
3627             my $extra = $self->{extra} || '';
3628             $code = "(($extra), \$C)[-1]";
3629         }
3630         elsif ($text eq '::') {
3631             $code = "\$C->_COMMITLTM$::REV()";
3632         }
3633         elsif ($text eq '::>') {
3634             $code = "\$C->_COMMITBRANCH$::REV()";
3635         }
3636         elsif ($text eq ':::') {
3637             $code = "\$C->_COMMITRULE$::REV()";
3638         }
3639         elsif ($text eq '\\d') {
3640             if ($::REV) {
3641                 return DEEP::p5regex($not ? '(?<=\D)' : '(?<=\d)');
3642             }
3643             else {
3644                 return DEEP::p5regex($not ? '\D' : '\d');
3645             }
3646         }
3647         elsif ($text eq '\\w') {
3648             if ($::REV) {
3649                 return DEEP::p5regex($not ? '(?<=\W)' : '(?<=\w)');
3650             }
3651             else {
3652                 return DEEP::p5regex($not ? '\W' : '\w');
3653             }
3654         }
3655         elsif ($text eq '\\s') {
3656             if ($::REV) {
3657                 return DEEP::p5regex($not ? '(?<=\W)' : '(?<=\w)');
3658             }
3659             else {
3660                 return DEEP::p5regex($not ? '\S' : '\s');
3661             }
3662         }
3663         elsif ($text eq '\\h') {
3664             if ($::REV) {
3665                 return DEEP::p5regex($not ? '(?<=[^\x20\t\r])' : '(?<=[\x20\t\r])');
3666             }
3667             else {
3668                 return DEEP::p5regex($not ? '[^\x20\t\r]' : '[\x20\t\r]');
3669             }
3670         }
3671         elsif ($text eq '\\v') {
3672             if ($::REV) {
3673                 return DEEP::p5regex($not ? '(?<=[^\n])' : '(?<=[\n])');
3674             }
3675             else {
3676                 return DEEP::p5regex($not ? '[^\n]' : '\n');
3677             }
3678         }
3679         elsif ($text eq '»') {
3680             return DEEP::p5regex('\b');
3681         }
3682         elsif ($text eq '«') {
3683             return DEEP::p5regex('\b');
3684         }
3685         elsif ($text eq '>>') {
3686             $code = "\$C->_RIGHTWB$::REV()";
3687         }
3688         elsif ($text eq '<<') {
3689             $code = "\$C->_LEFTWB$::REV()";
3690         }
3691         elsif ($text eq '<(') {
3692             $code = "\$C->_LEFTRESULT$::REV()";
3693         }
3694         elsif ($text eq ')>') {
3695             $code = "\$C->_RIGHTRESULT$::REV()";
3696         }
3697         elsif ($text eq '<~~>') {
3698             $code = "\$C->$::NAME()";
3699             $bt = 1;
3700         }
3701         else {
3702             $code = "\$C->_EXACT$::REV(\"$text\")";
3703         }
3704         if ($not) { # XXX or maybe just .NOT on the end...
3705             $code = "\$C->_NOTCHAR( sub { my \$C=shift;\n" . ::indent($code) . "\n})";
3706         }
3707         DEEP::raw($code, precut => !$bt);
3708     }
3709 }
3710
3711 { package RE_cclass; use base "REbase";
3712     sub _walk {
3713         my $self = shift;
3714         my $text = $$self{text};
3715         $self->{i_needed} = 1;
3716         $text =~ s!(\/|\\\/)!\\$1!g;
3717         $text =~ s/\s//g;
3718         $text =~ s/\.\./-/g;
3719         $text =~ s/^-\[/[^/;
3720         $text = "(?<=$text)" if $::REV;
3721         if ($$self{i}) {
3722             DEEP::p5regex("(?i:$text)");
3723         }
3724         else {
3725             DEEP::p5regex($text, needs_bracket => 1);
3726         }
3727     }
3728 }
3729
3730 { package RE_noop; use base "REbase";
3731     sub _walk {
3732         my $self = shift;
3733         DEEP::raw('$C', precut => 1);
3734     }
3735
3736     sub has_trailing_ws {
3737         my $self = shift;
3738         my $before = shift;
3739
3740         $before;
3741     }
3742 }
3743
3744 { package RE_decl; use base "REbase";
3745     # because cutting one of these would be a disaster
3746     sub new {
3747         my $class = shift;
3748         my $self  = $class->SUPER::new(@_);
3749         $self->{r} = 0;
3750         $self;
3751     }
3752     sub clean { my $self = shift;
3753         $self->SUPER::clean;
3754         delete $self->{body};
3755     }
3756     sub _walk {
3757         my $self = shift;
3758         DEEP::raw($$self{body}, isblock => 1);
3759     }
3760
3761     sub has_trailing_ws {
3762         my $self = shift;
3763         my $before = shift;
3764
3765         $before;
3766     }
3767 }
3768
3769 { package RE_block; use base "REbase";
3770     sub clean { my $self = shift;
3771         $self->SUPER::clean;
3772         delete $self->{context};
3773         delete $self->{body};
3774     }
3775     sub _walk {
3776         my $self = shift;
3777         my $ctx = $$self{context};
3778         my $text = ::indent($$self{body});
3779         if ($ctx eq 'void') {
3780             return DEEP::raw("scalar(do {\n" . ::indent($text) . "}, \$C)", precut => 1);
3781         }
3782         elsif ($ctx eq 'bool') {
3783             return DEEP::raw("((\$C) x !!do {\n" . ::indent($text) . "})", precut => 1);
3784         }
3785         else {
3786             return DEEP::raw("sub {\n" . ::indent("my \$C=shift;\n" . $text) . "}", precut => 1);
3787         }
3788     }
3789
3790     sub has_trailing_ws {
3791         my $self = shift;
3792         my $before = shift;
3793
3794         $before;
3795     }
3796 }
3797
3798 { package RE_bracket; use base "REbase";
3799     sub clean { my $self = shift;
3800         $self->SUPER::clean;
3801         delete $self->{decl};
3802     }
3803     sub _walk {
3804         my $self = shift;
3805         my ($re, $r) = $$self{re}->walk->uncut;
3806         my @decl = map { $_->walk } @{$$self{decl}};
3807         DEEP::raw("\$C->_BRACKET$r(" . ::hang(DEEP::chunk($re, @decl)->p5expr, "    ") . ")");
3808     }
3809
3810     sub kids { my $self = shift; \$self->{re} }
3811
3812     sub remove_leading_ws {
3813         my $self = shift;
3814         my $re = $$self{re};
3815         $re->remove_leading_ws();
3816     }
3817
3818     sub has_trailing_ws {
3819         my $self = shift;
3820         my $before = shift;
3821         $$self{re}->has_trailing_ws($before);
3822     }
3823 }
3824
3825 { package RE_var; use base "REbase";
3826     sub _walk {
3827         my $self = shift;
3828         my $var = $$self{var};
3829         if ($var =~ /^\$/) {
3830             if ($var =~ /^\$M->{(.*)}/) {
3831                 my $p = (substr($1,0,1) eq "'") ? "n" : "p";
3832                 DEEP::raw("\$C->_BACKREF$p$::REV($1)");
3833             }
3834             else {
3835                 DEEP::raw("\$C->_EXACT$::REV($var)");
3836             }
3837         }
3838         elsif ($var =~ /^\@/) {
3839             DEEP::raw("\$C->_ARRAY$::REV($var)");
3840         }
3841         elsif ($var =~ /^\%/) {
3842             DEEP::raw("\$C->_HASH$::REV($var)");
3843         }
3844     }
3845 }
3846
3847 { package RE_paren; use base "REbase";
3848     sub clean { my $self = shift;
3849         $self->SUPER::clean;
3850         delete $self->{decl};
3851     }
3852     sub _walk {
3853         my $self = shift;
3854         my $re;
3855         {
3856             local %::BINDINGS;
3857             $re = $$self{re}->walk->p5block;
3858             if (%::BINDINGS) {
3859                 for my $binding ( keys %::BINDINGS ) {
3860                     next unless $::BINDINGS{$binding} > 1;
3861                     my $re = <<"END" . $re;
3862 \$C->{'$binding'} = [];
3863 END
3864                 }
3865             }
3866         }
3867         $re = "\$C->_$::REV"."PAREN( " . ::hang(DEEP::chunk(DEEP::raw($re))->p5expr, "    ") . ")";
3868         DEEP::raw($re);
3869     }
3870
3871     sub kids { my $self = shift; \$self->{re} }
3872
3873     # yes, () would capture the ws, but we're guaranteed to be past it already
3874     sub remove_leading_ws {
3875         my $self = shift;
3876         my $re = $$self{re};
3877         $re->remove_leading_ws();
3878     }
3879
3880     sub has_trailing_ws {
3881         my $self = shift;
3882         my $before = shift;
3883         $$self{re}->has_trailing_ws($before);
3884     }
3885 }
3886
3887 { package RE_bindpos; use base "REbase";
3888     sub clean { my $self = shift;
3889         $self->SUPER::clean;
3890         delete $self->{var};
3891     }
3892     sub _walk {
3893         my $self = shift;
3894         my $var = $$self{var};
3895         $::BINDINGS{$var} += $::PLURALITY;
3896         my $re = $$self{atom}->walk;
3897         $self->bind($re, $var);
3898     }
3899
3900     sub kids { my $self = shift; \$self->{atom} }
3901
3902     sub remove_leading_ws {
3903         my $self = shift;
3904         my $re = $$self{atom};
3905         $re->remove_leading_ws();
3906     }
3907
3908     sub has_trailing_ws {
3909         my $self = shift;
3910         my $before = shift;
3911         $$self{atom}->has_trailing_ws($before);
3912     }
3913 }
3914
3915 { package RE_bindnamed; use base "REbase";
3916     sub clean { my $self = shift;
3917         $self->SUPER::clean;
3918         delete $self->{var};
3919     }
3920     sub _walk {
3921         my $self = shift;
3922         my $var = $$self{var};
3923         # XXX STD for gimme5 bug-compatibility, names push inside quantifiers
3924         $::BINDINGS{$var} += $::PLURALITY;
3925         if ($$self{atom}->isa('RE_quantified_atom')) {
3926             local $::BINDINSIDE = $var;
3927             return $$self{atom}->walk;
3928         }
3929         my $re = $$self{atom}->walk;
3930         $self->bind($re, $var);
3931     }
3932
3933     sub kids { my $self = shift; \$self->{atom} }
3934
3935     sub remove_leading_ws {
3936         my $self = shift;
3937         my $re = $$self{atom};
3938         $re->remove_leading_ws();
3939     }
3940
3941     sub has_trailing_ws {
3942         my $self = shift;
3943         my $before = shift;
3944         $$self{atom}->has_trailing_ws($before);
3945     }
3946 }
3947
3948 # DEEP is the lowest level of desugaring used by viv, but it still keeps a tree
3949 # structure.  Not all DEEP nodes are interchangable; some represent expression
3950 # bits, others statements with no sensible return value.
3951 { package DEEPbase;
3952 }
3953
3954 { package DEEPexpr;
3955     sub maybacktrack { 1 }
3956
3957     sub uncut { my $self = shift; $self, ($self->maybacktrack ? '' : 'r') }
3958
3959     # p5 should return (is a block?), text; takes arguments sh (can shadow $C?)
3960     # and ov (can overwrite $C?); non-block returns may not shadow
3961     sub p5expr { my $self = shift;
3962         my ($isbl, $text) = $self->p5(@_, sh => 1);
3963         $isbl ? ("do {\n" . ::indent($text) . "\n}") : $text;
3964     }
3965
3966     sub p5block { my $self = shift;
3967         my ($isbl, $text) = $self->p5(@_);
3968         $isbl ? $text : ($text . "\n");
3969     }
3970
3971     # psq returns the same as p5 for now
3972     sub psqexpr { my $self = shift;
3973         my ($isbl, $text) = $self->psq(@_, sh => 1);
3974         $isbl ? ("do {\n" . ::indent($text) . "\n}") : $text;
3975     }
3976 }
3977
3978 { package DEEP::raw; our @ISA = 'DEEPexpr';
3979     sub DEEP::raw {
3980         my $text = shift;
3981         bless { text => $text, @_ }, "DEEP::raw";
3982     }
3983
3984     sub maybacktrack {
3985         my $self = shift;
3986         return !$self->{precut};
3987     }
3988
3989     sub p5 { my $self = shift;
3990         $self->{isblock}, $self->{text};
3991     }
3992
3993     sub psq { my $self = shift;
3994         $self->{isblock}, $self->{text};
3995     }
3996 }
3997
3998 { package DEEP::cut; our @ISA = 'DEEPexpr';
3999     sub DEEP::cut {
4000         my $child = shift;
4001         if (!$child->maybacktrack) {
4002             return $child;
4003         }
4004         if ($child->isa('DEEP::bind')) {
4005             return DEEP::bind(DEEP::cut($child->{child}), @{$child->{names}});
4006         }
4007         bless { child => $child }, "DEEP::cut";
4008     }
4009
4010     sub p5 { my $self = shift;
4011         1, "if (my (\$C) = (" . ::hang($self->{child}->p5expr, "    ") . ")) { (\$C) } else { () }\n";
4012     }
4013
4014     sub maybacktrack { 0 }
4015
4016     sub uncut {
4017         my $self = shift;
4018         my ($child_uncut) = $self->{child}->uncut;
4019         $child_uncut, 'r';
4020     }
4021 }
4022
4023 { package DEEP::bind; our @ISA = 'DEEPexpr';
4024     sub DEEP::bind {
4025         my $child = shift;
4026         my @names = @_;
4027         if ($child->isa('DEEP::bind')) {
4028             push @names, @{$child->{names}};
4029             $child = $child->{child};
4030         }
4031         bless { child => $child, names => \@names }, "DEEP::bind";
4032     }
4033
4034     sub maybacktrack { $_[0]{child}->maybacktrack }
4035
4036     sub p5 { my $self = shift;
4037         my ($chinner, $r) = $self->{child}->uncut;
4038         0, "\$C->_SUBSUME$r([" .
4039             join(',', map {"'$_'"} @{$self->{names}}) .
4040             "], sub {\n" . ::indent("my \$C = shift;\n" .
4041             $chinner->p5block(cl => 1, sh => 1)) . "})";
4042     }
4043 }
4044
4045 { package DEEP::ratchet; our @ISA = 'DEEPexpr';
4046     sub DEEP::ratchet {
4047         my $child = shift;
4048         my @before = @_;
4049         if (::DARE_TO_OPTIMIZE) {
4050             if ($child->isa('DEEP::ratchet')) {
4051                 push @before, @{$child->{before}};
4052                 $child = $child->{child};
4053             }
4054             my ($chinner, $chr) = $child->uncut;
4055             if ($chr && $chinner != $child) {
4056                 push @before, $chinner;
4057                 $child = DEEP::raw('$C', precut => 1);
4058             }
4059         }
4060         bless { child => $child, before => \@before }, "DEEP::ratchet";
4061     }
4062
4063     sub maybacktrack { $_[0]{child}->maybacktrack }
4064
4065     sub p5 { my $self = shift; my %a = @_;
4066         if (@{$self->{before}} == 1) {
4067             my $pre = $self->{before}[0];
4068             return 1, "if (my (\$C) = (" . ::hang($pre->p5expr, " " x 8). ")) {\n" .
4069                 ::indent($self->{child}->p5block) . "} else { () }\n";
4070         }
4071         my $conditional = join ::hang("\nand ", "    "),
4072             map { "(\$C) = (" . ::hang($_->p5expr, " " x 8) . ")" }
4073             @{$self->{before}};
4074
4075         my $guts = ($conditional ?
4076             "if ($conditional) {\n" .
4077                 ::indent($self->{child}->p5block) . "} else { () }\n"
4078             : $self->{child}->p5block(cl => 1, sh => 1));
4079
4080         $guts = "my \$C = \$C;\n" . $guts unless $a{cl};
4081         $guts = "do {\n" . ::indent($guts) . "};\n" unless $a{sh};
4082         1, $guts;
4083     }
4084 }
4085 # NOT a regex bit, but a value
4086 { package DEEP::chunk; our @ISA = 'DEEPexpr';
4087     sub DEEP::chunk {
4088         my $child = shift;
4089         bless { child => $child, decl => \@_ }, "DEEP::chunk";
4090     }
4091
4092     sub p5 {
4093         my $self = shift;
4094         0, "sub {\n" . ::indent(
4095             "my \$C=shift;\n" .
4096             join("", map { $_->p5block } @{ $self->{decl} }) .
4097             $self->{child}->p5block(cl => 1, sh => 1)) . "}";
4098     }
4099 }
4100
4101 { package DEEP::p5regex; our @ISA = 'DEEPexpr';
4102     sub DEEP::p5regex {
4103         my $text = shift;
4104         bless { text => $text, has_meta => 1, @_ }, "DEEP::p5regex";
4105     }
4106
4107     sub p5 {
4108         my $self = shift;
4109         0, $self->{has_meta} ?
4110             "\$C->_PATTERN(qr/\\G" . $self->{text} . "/)" :
4111             "\$C->_EXACT(\"" . $self->{text} . "\")";
4112     }
4113
4114     sub cutre {
4115         my $self = shift;
4116         my $btoo = shift;
4117         $self->{needs_cut} ? "(?>" . $self->{text} . ")"
4118                            : ($btoo && $self->{needs_bracket}
4119                                 ? "(?:" . $self->{text} . ")"
4120                                 : $self->{text});
4121     }
4122
4123     sub maybacktrack { 0 }
4124 }
4125
4126 { package DEEP::call; our @ISA = 'DEEPexpr';
4127     sub DEEP::call {
4128         my ($name, @args) = @_;
4129         bless { name => $name, args => \@args }, "DEEP::call";
4130     }
4131
4132     my %psq_map = (
4133         'note',         => "System.Console.Error.WriteLine"
4134     );
4135
4136     sub psq { my $self = shift;
4137         my $n = $self->{name};
4138         my $np = $psq_map{$n};
4139         if (!ref $np) {
4140             my $n2 = $psq_map{$n} // $n;
4141             if ($n2 =~ /infix:<(.*)>/) {
4142                 my $op = " $1 ";
4143                 $np = sub { my ($a1, $a2) = @_;
4144                     "(" . $a1->psqexpr . $op . $a2->psqexpr . ")"; };
4145             }
4146             elsif ($n2 =~ /prefix:<(.*)>/) {
4147                 my $op = $1;
4148                 $np = sub { my ($a) = @_;
4149                     "(" . $op . $a->psqexpr . ")"; };
4150             }
4151             elsif ($n2 =~ /postfix:<(.*)>/) {
4152                 my $op = $1;
4153                 $np = sub { my ($a) = @_;
4154                     "(" . $a->psqexpr . $op . ")"; };
4155             }
4156             else {
4157                 $np = sub { $n2 . "(" . join(", ",
4158                         map { $_->psqexpr } @_) . ")" };
4159             }
4160             $psq_map{$n} = $np;
4161         }
4162         return 0, $np->(@{$self->{args}});
4163     }
4164 }
4165
4166 unless (caller) {
4167     if ($OPT_compile_setting) {
4168         STD->parsefile($OPT_compile_setting, setting => "NULL");
4169         exit 0;
4170     }
4171
4172     HelpMessage() unless @ARGV || $PROG;
4173     my $r;
4174     if ($OPT_thaw) {
4175         my $raw = retrieve($_[0]);
4176         $ORIG = $raw->{ORIG};
4177         $r = $raw->{AST};
4178         $STD::ALL = $raw->{STABS};
4179         for my $cl (keys %{$raw->{GENCLASS}}) {
4180             Actions::gen_class($cl, $raw->{GENCLASS}->{$cl});
4181         }
4182     }
4183     elsif (@ARGV and -f $ARGV[0]) {
4184         $r = STD->parsefile($ARGV[0], text_return => \$ORIG,
4185             actions => 'Actions')->{'_ast'};
4186     }
4187     else {
4188         if (not $PROG) {
4189             local $/;
4190             @ARGV = @_;
4191             $PROG = <>;
4192         }
4193         $ORIG = $PROG;
4194         $r = STD->parse($PROG, actions => 'Actions')->{'_ast'};
4195     }
4196     unless ($OPT_thaw) {
4197         $ORIG =~ s/\n;\z//;
4198     }
4199     if ($OPT_stab) {
4200         no warnings;
4201         $r->{stabs} = $STD::ALL;
4202     }
4203     if ($OPT_output eq 'yaml') {
4204         my $x = Dump($r);
4205 #       $x =~ s/\n.*: \[\]$//mg;
4206         spew $x;
4207     }
4208     elsif ($OPT_output eq 'concise') {
4209         spew concise($r, 80);
4210     }
4211     elsif ($OPT_output eq 'p6') {
4212         spew $r->p6;
4213     }
4214     elsif ($OPT_output eq 'psq') {
4215         spew $r->psq;
4216     }
4217     elsif ($OPT_output eq 'p5') {
4218         spew fixpod($r->p5);
4219     }
4220     elsif ($OPT_output eq 'none') {
4221         say "@ARGV syntax OK";
4222     }
4223     elsif ($OPT_output eq 'store') {
4224         delete $r->{stabs};
4225         no warnings 'once';
4226         my $data = { AST => $r, GENCLASS => \%Actions::GENCLASS,
4227             ORIG => $ORIG, STABS => $STD::ALL };
4228         defined($OPT_output_file) ? store($data, $OPT_output_file)
4229             : Storable::store_fd($data, \*STDOUT);
4230     }
4231     else {
4232         die "Unknown output mode";
4233     }
4234 }
4235
4236 1;
4237
4238 # vim: ts=8 sw=4 noexpandtab smarttab