src/perl6/viv

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