src/perl6/viv

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