src/perl6/viv

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