#!/usr/local/bin/perl

use 5.010;
use strict;
use warnings;
use Text::Balanced qw(extract_bracketed);
binmode(STDIN, ":utf8");
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
use Encode;
use utf8;

my $failover = 0;
if (@ARGV) {
    if ($ARGV[0] eq '-fo') {
        $failover = 1; shift;
    }
}

use YAML::XS;

our $SEQ = 0;

our %OUR = ( '$::CTX' => 1 );
our $RETREE = {};
our @RETREE = {};

our $STOP = "";
our $REV = "";
our $NAME = "";
our @BINDINGS;	# list of names to bind to
our %BINDINGS;	# count of how many times name used in this rule
our $BINDNUM = 1;	# is this a singular or plural binding?
our $KIND = "";
our $PARSEBIND = 0;
our $PAREN = 0;
our %adverbs = ('i' => 0, 'a' => 0,);
our %fixedprefix;
our $PURE;
our $MAYBACKTRACK;
our @STUFFED;
our @DECL;
our $SYM;
our $ENDSYM;
our $NEEDMATCH;
our %NEEDSEMI;
our $NEEDORIGARGS;
our $PKG = "main";
our $TOP = "STD";
our @PKG = ();
our $ALTNAME;
our $ALTNAMES;
our $PROTO;
our $ENDMATTER;

my %pkg_really;
my %proto;
my %protosig;

my $TRACE = 0;
my $METHOD = "method";

my @impure = qw/ ws fail commit before after panic /;
my %impure;

require "mangle.pl";

sub unangle {
    my $s = shift;
    $s =~ s/<(\w*)>/{'$1'}/g;
    $s =~ s/<([^>]*)>/{'$1'}/g;
    $s =~ s/«([^»]*)»/{'$1'}/g;
    $s =~ s/ /','/g;
    $s;
}

sub un6 {
    my $f = shift;
    #my $trace = $f =~ /PARSER/;
    my $t;
    $f =~ s/\\x([0-9a-fA-F]{3,4})/\\x{$1}/g;
    $f =~ s!\$([0-9]+)!\$C<$1>!g;
    $f =~ s/(\S+)\s*:(exists|delete)/$2 $1/g if $f =~ /:(exists|delete)/;
    while ($f ne "") {
	#print "$f\n" if $trace;
        $f =~ s/^\$(\w+)\.?([\[{])//         	and $t .= qq/\$$1->$2/, next;
        $f =~ s/^\$\*(\w+)\.?([\[{])//         	and $t .= qq/\$::$1->$2/, next;
        $f =~ s/^\$(\w+)\.?</.</         	and $t .= qq/\$$1/, next;
        $f =~ s/^\$\*(\w+)\.?</.</         	and $t .= qq/\$::$1/, next;
        $f =~ s/^\)</.</                  	and $t .= ')', next;
        $f =~ s/^\.\(/(/                  	and $t .= '->', next;
        $f =~ s/^\.\{/{/                  	and $t .= '->', next;
	$f =~ s/^\[\*-1\]//			and $t .= '[-1]';
        $f =~ s!^('.*?')!!              	and $t .= $1, next;
        $f =~ s!^(".*?")!!              	and $t .= $1, next;
	$f =~ s!^ self\.WHAT!!			and $t .= ' (ref($self)||$self)', next;
	$f =~ s!^ self\.pos\b!!	        	and $t .= ' $self->{\'_pos\'}', next;
	$f =~ s!^\$¢\.pos\b!!			and $t .= '$C->{\'_pos\'}', next;
        $f =~ s!^//!!              		and $t .= "//", next;	# default operator
	$f =~ s!^m:P5(\W)(.+?)\1/!!		and $t .= "m$1$2$1", next;
	$f =~ s!^s:P5(\W)(.+?)\1(.*?)\1/!!	and $t .= "s$1$2$1$3$1", next;
        $f =~ s!^q/(.*?)/!!              	and $t .= "q/$1/", next;
        $f =~ s!^s/(.*?)/!!              	and $t .= "s/$1/", next;
        $f =~ s!^(?:rx)?/(.+?)/!!              	and $t .= "qr/$1/", next;
        $f =~ s/^\$¢\.\$parser//                and $t .= qq/\$C->\$parser/, next;
        $f =~ s/^\$¢//                  	and $t .= qq/\$C/, next;
        $f =~ s/^\$\/\.//                  	and $t .= qq/\$M->/, $NEEDMATCH++, next;
        $f =~ s/^\$\/</.</                  	and $t .= qq/\$M/, $NEEDMATCH++, next;
        $f =~ s/^ ::(\w+(?:::\w+)*)\[(.*?)\]/$2)/ and $t .= qq/ '@{[ $pkg_really{$1} || "${PKG}::$1" ]}'->__instantiate__(/, next;
        $f =~ s/^ ::($TOP(?:::\w+)*)// 		and $t .= qq/ '$1'/, next;
        $f =~ s/^ ::(\w+(?:::\w+)*)// 		and $t .= qq/ '@{[ $pkg_really{$1} || "${PKG}::$1" ]}'/, next;
        $f =~ s/^([^:]):(\w+)\((.*?)\)/ ($3)/ 	and $t .= qq/$1'$2' =>/, next;
        $f =~ s/^([^:]):([\$\@%])(\w+)//        and $t .= qq/$1'$3' => $2$3/, next;
        $f =~ s/^([^:]):(\w+)<(.*?)>//  	and $t .= qq/$1'$2' => '$3'/, next;
        $f =~ s/^([^:]):(\w+)«(.*?)»//  	and $t .= qq/$1'$2' => '$3'/, next;
        $f =~ s/^([^:]):(\w+)//         	and $t .= qq/$1'$2' => 1/, next;
        $f =~ s/^([^:]):!(\w+)//        	and $t .= qq/$1'$2' => 0/, next;
        $f =~ s/^\%::\((.*?)\)// 		and $t .= ("do { no strict 'refs'; \\%{$1}}"), next;
        $f =~ s/^\%(\w+)\.?((<[^>]*>)+)// 	and $t .= ('$' . $1 . unangle($2)), next;
        $f =~ s/^\%\*(\w+)\.?((<[^>]*>)+)// 	and $t .= ('$::' . $1 . unangle($2)), next;
        $f =~ s/^\%(\w+)\{@//         	        and $t .= qq/\@$1\{@/, next;    # durn slices...
        $f =~ s/^\%\*(\w+)\{@//         	and $t .= qq/\@::$1\{@/, next;    # durn slices...
        $f =~ s/^\%(\w+)\.?\{/{/         	and $t .= qq/\$$1/, next;
        $f =~ s/^\%\*(\w+)\.?\{/{/         	and $t .= qq/\$::$1/, next;
        $f =~ s/^\%(\w+)//                     	and $t .= qq/%$1/, next;
        $f =~ s/^\@(\w+)\.?\[/[/          	and $t .= qq/\$$1/, next;
        $f =~ s/^\@\*(\w+)\.?\[/[/          	and $t .= qq/\$::$1/, next;
        $f =~ s/^([\$\@%])\*(\w+)//             and $t .= qq/${1}::$2/, next;
        $f =~ s/^\$(\w+)((<[^>]*>)+)//  	and $t .= ('$' . $1 . '->' . unangle($2)), next;
        $f =~ s/^[\$\@%]((<[^>]*>)+)//       	and $t .= ('$M->' . unangle($1)), $NEEDMATCH++, next;
        $f =~ s/^ \.((<[^>]*>)+)//      	and $t .= (' $_->' . unangle($1)), next;
        $f =~ s/^ < ([^«»])/$1/ 		and $t .= qq/ < /, next;
        $f =~ s/^(\s)<([^>) ,]*)>//       	and $t .= qq/$1q($2)/, next;
        $f =~ s/^(\s)<([^>),]*)>,//       	and $t .= qq/$1qw($2),/, next;
        $f =~ s/^(\s)<([^>),]*)>//       	and $t .= qq/$1\[qw($2)\]/, next;
        $f =~ s/^(\s)<([^> ]*)>//        	and $t .= qq/$1q[$2]/, next;
        $f =~ s/^(\s)<([^>]*)>//        	and $t .= qq/$1\[qw[$2]\]/, next;
        $f =~ s/^«([^») ]*)»//      	        and $t .= qq/q($1)/, next;
        $f =~ s/^«([^»)]*)»//      	        and $t .= qq/\[qw($1)\]/, next;
        $f =~ s/^«([^» ]*)»//      	        and $t .= qq/q[$1]/, next;
        $f =~ s/^«([^»]*)»//      	        and $t .= qq/\[qw[$1]\]/, next;
        $f =~ s/^ «\s*([^»]+)»//        	and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "['$x']"}, next;
        $f =~ s/^ <\s*([^>]+)>//        	and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "['$x']"}, next;
        $f =~ s/^\.<\s*([^>]+)>//             	and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "->{'$x'}"}, next;
        $f =~ s/^<\s*([^>]+)>//             	and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "{'$x'}"}, next;
        $f =~ s/^(\w+)((<[^>]*>)+)//    	and $t .= ($1 . '->' . unangle($2)), next;
        $f =~ s/^(\w+)((«[^»]*»)+)//    	and $t .= ($1 . '->' . unangle($2)), next;
        $f =~ s/^\.pos\b//         	        and $t .= qq/->{'_pos'}/, next;
        $f =~ s/^self\.orig\b//         	and $t .= qq/\$::ORIG/, next;
	$f =~ s!^\.pos\b!!			and $t .= '->{\'_pos\'}', next;
        $f =~ s/^(\$\w+)\.pos//            	and $t .= $1 . '->{\'_pos\'}', next;
        $f =~ s/^(\$\w+)\.//            	and $t .= qq/$1->/, next;
        $f =~ s/^(\$\w+)\(/(/            	and $t .= qq/$1->/, next;
        $f =~ s/^\(\$s:\)//            	        and $t .= qq/(\$s)/, next;
        $f =~ s/^\$[!.](\w+)//          	and $t .= qq/\$self->{$1}/, next;
        $f =~ s/^\@[!.](\w+)\././               and $t .= qq/\$self->{$1}/, next;
        $f =~ s/^\%[!.](\w+)\././               and $t .= qq/\$self->{$1}/, next;
        $f =~ s/^\@[!.](\w+)([\[{<])/.$2/       and $t .= qq/\$self->{$1}/, next;
        $f =~ s/^\%[!.](\w+)([\[{<])/.$2/       and $t .= qq/\$self->{$1}/, next;
        $f =~ s/^\@[!.](\w+)//          	and $t .= qq/\@{\$self->{$1}}/, next;
        $f =~ s/^\%[!.](\w+)//          	and $t .= qq/\%{\$self->{$1}}/, next;
        $f =~ s/^\&(${TOP}::)//          	and $t .= qq/*$1/, next;
        $f =~ s/^\@(\w+)([\[{])/$2/             and $t .= qq/\$$1/, next;
        $f =~ s/^\%(\w+)([\[{])/$2/             and $t .= qq/\$$1/, next;
        $f =~ s/^\|%/%/                         and next;
        $f =~ s/^\.HOW//         		and $t .= qq/->meta/, next;
        $f =~ s/^HOW//	         		and $t .= qq/meta/, next;
        $f =~ s/^\."(\$[A-Za-z]\w+)"//         	and $t .= qq/->$1/, next;
        $f =~ s/^\.([A-Za-z]\w+)//         	and $t .= qq/->$1/, next;
        $f =~ s/^!===?//                	and $t .= qq/!=/, next;
        $f =~ s/^===//                  	and $t .= qq/==/, next;
        $f =~ s/^!eqv//                	        and $t .= qq/ne/, next;
        $f =~ s/^eqv//                	        and $t .= qq/eq/, next;
        $f =~ s/^leg//                	        and $t .= qq/cmp/, next;
        $f =~ s/^item %//                	and $t .= qq/\\%/, next;
        $f =~ s/^item @//                	and $t .= qq/\\@/, next;
        $f =~ s/^([( ])\+@//                    and $t .= qq/${1}0+@/, next;
        $f =~ s/^ is rw//               	and $t .= qq//, next;
        $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%])\*(\w+)\b\s*(?:is\s+rw)?\s*;//
                                        	and $t .= qq/local $1::$2;/, $OUR{"$1::$2"}++, next;
        $f =~ s/^\borelse\b//           	and $t .= qq/or/, next;
        $f =~ s/^\bfail\b//             	and $t .= qq/die/, next;
        $f =~ s/^\blet\b //             	and $t .= qq//, next;
        $f =~ s/^\bTrue\b//             	and $t .= qq/1/, next;
        $f =~ s/^\bFalse\b//             	and $t .= qq/0/, next;
        $f =~ s/^\$?self\.pos\b//             	and $t .= qq/\$self->{'_pos'}/, next;
        $f =~ s/^\$?self\.//             	and $t .= qq/\$self->/, next;
        $f =~ s/^\$?self\b//             	and $t .= qq/\$self/, next;
        $f =~ s/^\.panic//              	and $t .= qq/->panic/, next;
        $f =~ s/^(\s)\+&(\s)/$2/            	and $t .= qq/$1&/, next;
        $f =~ s/^(\s)!~~(\s)/$2/            	and $t .= qq/$1!~/, next;
        $f =~ s/^(\s)~~(\s)/$2/            	and $t .= qq/$1=~/, next;
        $f =~ s/^(\s)~=(\s)/$2/            	and $t .= qq/$1.=/, next;
        $f =~ s/^(\s)~(\s)/$2/            	and $t .= qq/$1./, next;
        $f =~ s/^(\s):?:=(\s)/$2/           	and $t .= qq/$1=/, next; # XXX fake binding with assignment
        $f =~ s/^(\s)\?\?(\s)/$2/         	and $t .= qq/$1?/, next;
        $f =~ s/^(\s)!!(\s)/$2/           	and $t .= qq/$1:/, next;
        $f =~ s/^\bmap( \{.*?\}),/$1/           and $t .= qq/map/, next;
        $f =~ s/^\bgrep( \{.*?\}),/$1/          and $t .= qq/grep/, next;
        $f =~ s/^\bsort( \{.*?\}),/my $x = $1; $x =~ s!\$\^!\$!g; $x/e          and $t .= qq/sort/, next;
        $f =~ s/^\btry \{//                     and $t .= qq/eval {/, next;
        $f =~ s/^\bloop \{//                    and $t .= qq/for (;;) {/, next;
        $f =~ s/^\bwhen\s+\*\s+\{//             and $t .= qq/default {/, next;
#        $f =~ s/^\bdefault\s+\{//               and $t .= qq/else {/, next;
        $f =~ s/^\btemp\s+([\$\@%])\*?(\w+)\s*(::)?=// and $t .= qq/local $1::$2 =/, next;
        $f =~ s/^\btemp\s+([\$\@%])\*?(\w+)//     and $t .= qq/local $1::$2 = $1::$2/, next; # dumb p5 semantics
        $f =~ s/^\btemp\b//             	and $t .= qq/local/, next;
        $f =~ s/^\binvert\b//             	and $t .= qq/reverse/, next;
        $f =~ s/^\bMu\b//                	and $t .= qq/undef/, next;
        $f =~ s/^\bNil\b//                	and $t .= qq/()/, next;
        $f =~ s/^\bchars\(//             	and $t .= qq/length(/, next;
        $f =~ s/^\bnote\b//             	and $t .= qq/print STDERR /, next;
        $f =~ s/^\$\?PACKAGE//             	and $t .= qq/__PACKAGE__/, next;

        # the following must do partial rescan of final expression

        $f =~ s/^\@\((.*?)\)/{$1}/      	and $t .= qq/\@/, next;
        $f =~ s/^\bif\s+(.*?\S)(\s+\{)/($1)$2/        and $t .= qq/if /, next;
        $f =~ s/^\belsif\s+(.*?\S)(\s+\{)/($1)$2/     and $t .= qq/elsif /, next;
        $f =~ s/^\bwhile\s+(.*?\S)(\s+\{)/($1)$2/     and $t .= qq/while /, next;
        $f =~ s/^\bfor\s+(.*?\S)(\s+\{)/($1)$2/       and $t .= qq/for /, next;
        $f =~ s/^\bgiven\s+(.*?\S)(\s+\{)/($1)$2/       and $t .= qq/given /, next;
        $f =~ s/^\bwhen\s+(.*?\S)(\s+\{)/($1)$2/       and $t .= qq/when /, next;
        $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%])\*(\w+)\b\s*(?:is\s*rw)?\s*:?:?=(\s*.*);/$3;/s
                                        	and $t .= qq/local $1::$2 =/, $OUR{"$1::$2"}++, next;
#        $f =~ s/^\bdo given\s+(.*?\S)\s+\{/$1; if (0) {}/
#                                                and $t .= qq/do { my \$_ = /, next;
#        $f =~ s/^\bgiven\s+(.*?\S)\s+\{/$1; if (0) {}/
#                                                and $t .= qq/do { my \$_ = /, next;
#        $f =~ s/^\bwhen\s+(.*?\S)\s+\{/$1) {/
#                                                and $t .= 'elsif ($_ eq ', next;

        $f =~ s/^(\#.*)//                 	and $t .= $1, next;
        $f =~ s/^&reduce\(\)//                  and $t .= "\$reduce->()", next;
        $f =~ s/^(\w+)//s                 	and $t .= $1, next;
        $f =~ s/^(.)//s                 	and $t .= $1;
    }
    $t;
}

{
    open(IN, $ARGV[0]) or die "Can't open $ARGV[0]: $!\n";
    {
	local $/;
	binmode(IN, ':utf8');
	$_ = <IN>;
    }
    close IN;
    push @impure, m/^method (\w+)/mg;
    @impure{@impure} = (1) x @impure;
    #warn "@impure\n";
}
my $all = $_;

sub indent {
    my $x = shift || '';
    my $i = shift || 1;
    my $s = '  ' x $i;
    $x =~ s/^/$s/mg;
    $x;
}

sub panic {
    my $line = 0;
    while (length($all) > length($_)) {
        if ($all =~ s/^#line (\d+)\n//) {
            $line = $1;
        }
        else {
            $all =~ s/^.*\n//;
            $line++;
        }
    }
    die @_,
        " at line ", $line - 1,
        " near '", /^(.{0,30}) /s,
        "'\n";
}

my $out = "";

sub MAIN {

    if (s/^((?:#.*\n)*?\s*)grammar (\w+(?:::\w+)*)(?::\w+<.*?>)*(?:\s*is\s+(\w+))?;\n/$1/) {
	$TOP = $PKG = $2;
	my $extends = $3 // 'Cursor';
	$out .= "package $PKG;\n";
	$out .= <<"END";
use Moose ':all' => { -prefix => "moose_" };
use $extends; # for base class as well as DEBUG constants
moose_extends('$extends');

no warnings 'qw', 'recursion';

my \$retree;

\$DB::deep = \$DB::deep = 1000; # suppress used-once warning

sub BUILD {
    my \$self = shift;
END


	$out .= <<'END';
}

use YAML::XS;

$SIG{__WARN__} = sub { print STDERR @_,"   statement started at line ", 'STD'->lineof($::LASTSTATE), "\n" } if $::DEBUG;

END
    }

    while ($_ ne "") {

        if ( s/^(#line.*\n)// ) { next }
	if ( s/^([ \t]*\n)// ) { $out .= $1; next; };
        if ( /^method EXPR / ) { $out .= <<'END'; }
sub EXPR__PEEK { $_[0]->_AUTOLEXpeek('EXPR',$retree) }
END


	if (s/^ [\x20\t]* (=begin \s+ (\w+) .*? \n [\x20\t]* =end \s+ \2 .*? \n) //sx) {
	    my $c = $1;
	    $c =~ s/^/# /mg;
	    $out .= $c;
	    next;
	}

        if ( s/^(#.*\n)// ) { $out .= $1; next }

        my $remaining = length($_);

	if (s/^(\s*)(proto \s+ (regex|rule|token|method) \s+
	    (\w+) \s*
	    (?:\(([^)]*)\))?.*?\{[<.!>\s]*}.*?\n)//x)
	{
	    $out .= '#' . $2;
	    my $name = $4;
	    my $pkgname = $PKG . '::' . $name;
	    $proto{$name}++;
	    $protosig{$name} = $5;
	    $out .= <<"END";
sub ${name}__PEEK { \$_[0]->_AUTOLEXpeek('$name:*',\$retree); }
sub $name {
    my \$self = shift;
    my \$subs;

    local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;

    my \$C = \$self->cursor_xact('RULE $name');
    my \$S = \$C->{'_pos'};

    my \@result = do {
	my (\$tag, \$try);
        my \@try;
        my \$relex;
        my \$x;
        if (my \$fate = \$C->{'_fate'}) {
            if (\$fate->[1] eq '$name') {
                \$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
                (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
                \@try = (\$try);
                \$x = 'ALT $name';
            }
            else {
                \$x = 'ALTLTM $name';
            }
        }
        else {
            \$x = 'ALTLTM $name';
        }
        my \$C = \$C->cursor_xact(\$x);
        my \$xact = \$C->{_xact};

	my \@gather = ();
        for (;;) {
            unless (\@try) {
                \$relex //= \$C->cursor_fate('$PKG', '$name:*', \$retree);
                \@try = \$relex->(\$C) or last;
            }
	    \$try = shift(\@try) // next;
    
            if (ref \$try) {
                (\$C->{'_fate'}, \$tag, \$try) = \@\$try;	# next candidate fate
            }
    
	    \$C->deb("$name trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
	    push \@gather, \$C->\$try(\@_);
            last if \@gather;
            last if \$xact->[-2];  # committed?
	}
	\$self->_MATCHIFYr(\$S, "$name", \@gather);
    };
    \@result;
}

END
	    next;
	}

	if (s/^([ \t]*)(?:multi\s+)?
	    (regex|rule|token) \s+
	    (\w+) ( :\w+ ( <.*?>
			| «.*?»
			| \{.*?\}
			| \[.*?\]
			)?
		  ) \s*
	    (?:\(([^)]*)\))?//x)
	{
	    my $indent = $1;
	    my $kind = $2;
	    my $name = $3;
	    my $adv = $4;
	    my $sig = $6;

	    my $newdflt = $adv;
	    $newdflt =~ s/:(\w+)$/'$1'/ or
	    $newdflt =~ s/:sym(<.*?>)/$1/ or
	    $newdflt =~ s/:sym(«.*?»)/$1/ or
	    $newdflt =~ s/:sym(\(.*?\))/$1/ or
	    $newdflt =~ s/:sym(\[.*?\])/$1/;

	    my $newparm = ":\$*sym = $newdflt";

	    my $newsig = $protosig{$name} || "";
	    if ($sig and $sig =~ s/( *--> *\w* *$)//) { $newsig .= ' ' . $1 }
	    if ($newsig =~ /^\s*-->/) {
		$newsig =~ s/-->/$newparm -->/;
	    }
	    elsif ($newsig =~ /-->/) {
		$newsig =~ s/-->/, $newparm -->/;
	    }
	    elsif ($newsig) {
		$newsig .= ', ' . $newparm;
	    }
	    else {
		$newsig = $newparm;
	    }
	    my $mangle = $adv;
	    $mangle =~ s/^:(sym)?//;
	    my @list;
	    if ($mangle =~ s/^<(.*)>$/$1/ or
		$mangle =~ s/^«(.*)»$/$1/) {
		$mangle =~ s/\\(.)/$1/g;
		@list = $mangle =~ /(\S+)/g;
	    }
	    elsif ($mangle =~ s/^\[(.*)\]$/$1/ or
		$mangle =~ s/^\{(.*)\}$/$1/) {
		@list = eval $mangle;
	    }
	    else {
		@list = $mangle;
	    }
	    $mangle = ::mangle(@list);
	    $mangle = $name . '__S_' . sprintf("%03d",$SEQ++) . $mangle;
	    substr($_,0,0,"$indent$kind $mangle ($newsig) ")
	}

	if (s/^(\s*)} # end (class|grammar|role).*\n//) {
	    my $ws = $1;
	    dumpretree();
	    $out .= "$ws$ENDMATTER ## end $2\n";
	    $RETREE = pop(@RETREE);
	    $PKG = pop(@PKG) if @PKG;
	    $ENDMATTER = '}';
	}

        if ( s/^([ \t]*)(proto)?\s*(method|rule|token|regex)(\s+)(\w+)(.*?)\s+{//s ) {
            my $indent = $1;
            my $proto = $2;
            local $KIND = $3;
            my $ws = $4;
            local $NAME = $5;
            my $argstuff = $6;

            my $comment = "$1$3$4$5$6\n";
            $comment =~ s/^/## /mg;
            $out .= $comment;

            local $PAREN = 0;
            local $SYM;
            local $ENDSYM;
            local $NEEDORIGARGS = 0;
            my $args = "";
            my $coercion = "";
            if ($argstuff =~ s/\((.*)\)//s) {
                $args = $1;
                $args =~ s/^\s+//;
                $args =~ s/\s+$//;
            }
            warn "ARGSTUFF in $NAME: ", $argstuff if $argstuff =~ /\S/;
            my $p = "";

            local $MAYBACKTRACK = 1;
	    $adverbs{r} = 0;
	    $adverbs{s} = 0;
	    $adverbs{dba} = $NAME;
            if ($KIND eq 'token' or $KIND eq 'rule') {
                $MAYBACKTRACK = 0;
		$adverbs{r} = 1;
		if ($KIND eq 'rule') {
		    $adverbs{s} = 1;
		}
            }

	    my $pkg;
            if ($args =~ s/ *--> *(\w*) *$//) {
		$pkg = $pkg_really{$1} || "${PKG}::$1";
            }
            $args .= ', ';
            my $sym = "";

            $args =~ s/is rw//g;
            while ($args =~ s/^([A-Z]\w+)?\s*([\$\@%&]\*?\w+\b)\s*([^=?,]*?),\s*//) {
                my $type = $1;
                my $var = $2;
                warn "EXTRA: ", $3 if $3;
                my $decl = ($var =~ s/\*/::/) ? ($OUR{$var}++, "local") : "my";
                $sym .= "    $decl $var = shift;\n";
                $args =~ s/^,\s*//;
            }

            while ($args =~ s/^([A-Z]\w+)?\s*([\$\@%&]\*?\w+)\s*=(.*?),\s*//) {
                my $type = $1;
                my $var = $2;
                my $dflt = $3;
                my $decl = $var =~ s/\*/::/ ? ($OUR{$var}++, "local") : "my";
                $dflt = un6($dflt);
                $sym .= "    $decl $var = shift() //$dflt;\n";  # XXX close enough
                $args =~ s/^,\s*//;
            }

            my $didargs = 0;
            while ($args =~ s/^([A-Z]\w+)?\s*:([\$\@%&]\*?(\w+))\s*(=((<[^>]*>|«[^»]*»|.)*?))?,\s*//) {
                my $type = $1;
                my $var = $2;
                my $name = $3;
                my $eq = $4;
                my $dflt = $5;
                my $decl = ($var =~ s/\*/::/) ? ($OUR{$var}++, "local") : "my";
                $sym .= "    my %args = \@_;\n" unless $didargs++;   # simulate named args from variadics
                if ($name eq 'sym') {
                    warn "NO DFLT: ", $args unless $dflt;
                    $SYM = $dflt;
                    $SYM =~ s/^\s+//;
                    $SYM =~ s/^'(.*)'$/$1/ or
                    $SYM =~ s/^"(.*)"$/$1/ or
                    $SYM =~ s/^<(.*)>$/$1/ or
                    $SYM =~ s/^«(.*)»$/$1/ or
                    $SYM =~ s/^\{'(.*)','(.*)'\}$/$1 $2/ or
                    $SYM =~ s/^\{'(.*)'\}$/$1/;
                    $SYM =~ s/^\s+//;
                    $SYM =~ s/\s+$//;
		    $SYM =~ s/\\(.)/$1/g;
                }
                if ($name eq 'endsym') {
                    warn "NO DFLT: ", $args unless $dflt;
                    $ENDSYM = $dflt;
                    $ENDSYM =~ s/^\s+//;
                    $ENDSYM =~ s/\s+$//;
                    $ENDSYM =~ s/^'(.*)'$/$1/ or
                    $ENDSYM =~ s/^"(.*)"$/$1/;
                }
                if ($eq) {
                    $dflt = un6($dflt);
                    $sym .= "    $decl $var = \$args{$name} //$dflt;\n";
                }
                else {
                    $sym .= "    $decl $var = \$args{$name};\n";
                }
                $args =~ s/^,\s*//;
            }

            if ($args =~ s/^([A-Z]\w+)?\s*\*([\$\@%&]\*?\w+)\s*([^=?,]*?),\s*//) {
                my $type = $1;
                my $var = $2;
                warn "EXTRA: ", $3 if $3;
                my $decl = ($var =~ s/\*/::/) ? ($OUR{$var}++, "local") : "my";
                $sym .= "    $decl $var = \@_;\n";
                $args =~ s/^,\s*//;
            }
            warn "EXTRA: ", $args if $args =~ /[^, ]/;

            if ($KIND eq 'method') {
                $out .= <<"END";
${indent}sub $NAME {
${indent}    my \$self = shift;
$sym
END
                next;
            }

            local @BINDINGS;
	    local %BINDINGS;
            local @DECL;

            local $ALTNAME = $NAME;
            local $ALTNAMES = "00";
            my $re = regex('\\}');
	    $re->{pkg} = $pkg;

            my $old = substr($all, length($all) - $remaining, $remaining - length($_)+1);
            $old =~ s/^/##      /mg;
            $out .= "$old\n\n";

            local $PURE = 1;
            local $PROTO = $proto;
            my $meat = ::indent($re->walk(), 2);

            $re->{kind} = $KIND;
            $RETREE->{$NAME} = $re;
            $re->remember_alts();

            my $body = <<"END";
sub$ws${NAME}__PEEK { <<PEEK>> }
sub$ws$NAME {
    no warnings 'recursion';
    my \$self = shift;
END
            if ($NEEDORIGARGS) {
                $body .= "    my \@origargs = \@_;\n";
            }
            $body .= <<"END";
    local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
<<DECL>>

    my \$C = \$self->cursor_xact("RULE $NAME");
    my \$xact = \$C->xact;
    my \$S = \$C->{'_pos'};
END

	    for my $binding ( keys %BINDINGS ) {
		next unless $BINDINGS{$binding} > 1;
		$body .= <<"END";
    \$C->{'$binding'} = [];
END
	    }
	    if ($SYM and $meat !~ /->_SYM\(\$sym\)/) {
		$body .= <<"END";
    \$C->{'sym'} = ref \$sym ? join(' ', @\$sym) : \$sym;
END
	    }

            if ($proto) {
                $body .= <<'END';

<<MEAT>>
END
            }
            else {
		if ($pkg) {
		    if ($MAYBACKTRACK) {
			$coercion = " Cursor::lazymap sub { $pkg->coerce(\$_[0]) }, ";
		    }
		    else {
			$coercion = " map { $pkg->coerce(\$_) } ";
		    }
		}
		my $ratchet = $MAYBACKTRACK ? '' : 'r';
                $body .= <<"END";

    \$self->_MATCHIFY$ratchet(\$S, "$NAME", $coercion
<<MEAT>>
    );
END
            }

            my $PROTONAME = $NAME;
            $PROTONAME =~ s/__.*// or $PROTONAME = "panic";
            if ($impure{$NAME}) {
                $body =~ s/<<PEEK>>/''/;
            }
            else {
                $body =~ s/<<PEEK>>/\$_[0]->_AUTOLEXpeek('<<NAME>>',\$retree)/;
            }
            $body =~ s/<<PKG>>/$PKG/g;
            $body =~ s/<<NAME>>/$NAME/g;
            $body =~ s/<<PROPS>>//g;
            $body =~ s/<<PROTONAME>>/$PROTONAME/g;
            $body =~ s/<<DECL>>/$sym@DECL/;
            $body =~ s/<<MEAT>>/$meat/;
            $body =~ s/\$\*(\w+)/\$::$1/g;
            $out .= $body;
            next;
        }

        if (s/^\s*multi method tweak\s*\((.*?)\)\s+{//) {
            my $sig = $1;
            if ($sig =~ m/^:(\w+)\(:(\$(\w+))\)!$/) {
                $out .= "    elsif (\$k eq '$1' or \$k eq '$3') {\n        my $2 = \$v; ";
            }
            elsif ($sig =~ m/^:(\w+)\((\$\w+)\)!$/) {
                $out .= "    elsif (\$k eq '$1') {\n        my $2 = \$v; ";
            }
            elsif ($sig =~ m/^:(\$(\w+))!$/) {
                $out .= "    elsif (\$k eq '$2') {\n        my $1 = \$v; ";
            }
            elsif ($sig =~ m/^\*%x$/) {
                $out .= "    elsif (1) {\n        my %x = (\$k, \$v); ";
            }
            else {
                warn "Can't translate tweak: $sig";
            }
            next;
        }

	if (s/^#begin p5\n(.*?\n)#end p5\n//s) {
	    $out .= $1;
	    next;
	}

        # from here on we assume all nibbles are line-sized or less.
        if (s/^(.*\n)//) {
            my $line = $1;
            if ($line =~ m/# begin tweaks/) {
                $out .= <<'END';
  sub multitweak { # begin tweaks
    my $self = shift;
    my ($k, $v) = @_;

    if (0) {}
END
                next;
            }
            elsif ($line =~ m/# end tweaks/) {
                $out .= "    else { die 'NOMATCH' }\n} # end tweaks\n";
                next;
            }
            if ($line =~ m/^#/) {
                $out .= $line;
                next;
            }
            if ($line =~ m/^(\s*)has\s+(?:[A-Z]\w+\s+)?[\$\@%][.!](\w+).*/) {
	    	$out .= "$1moose_has '$2' => (is => 'rw');";
                next;
            }

            $line = un6($line);

	    $line =~ s/COMPILING::<(\W+)(\w+)>/$1COMPILING::$2/g;
            $line =~ s/&reduce = ->/\$reduce = sub/;
            $line =~ s/ -> (.+?) {/sub { my ($1) = \@_;/;
            $line =~ s/ -> {/sub {/;
            $line =~ s/([\$\@%])\*(\w+)/${1}::$2/g;       # assume localized
            if ($line =~ s/^constant %/our %/) {
                $line =~ tr/{}/()/;
                $line = ::un6($line);
            }
            $line =~ s/^constant /my /;
            $line =~ s/\bmy ([A-Z]\w+) /my /;

            $line =~ s/(\s*)class (\w+)\s*(.*?)\s+\{/${1}{ package ${PKG}::$2;\n$1    use Moose ':all' => { -prefix => "moose_" };\n$1     my \$retree;/
                    and do {
			my $ws = $1;
			my $name = $2;
			my $is = $3;
			my @is;
			my @does;
			my @list = split ' ', $is;
			my $which;
			while (@list) {
			    my $next = shift @list;
			    if ($next eq 'is') {
				$which = \@is;
			    }
			    elsif ($next eq 'does') {
				$which = \@does;
			    }
			    else {
				push @$which, $pkg_really{$next} || "${PKG}::$next";
			    }
			}
			push(@PKG, $PKG);
			push(@RETREE, $RETREE);
			$RETREE = {};
			$pkg_really{$name} = $PKG = "${PKG}::$name";
			$line .= "$ws    moose_extends(qw(@is)); " if @is;
			$line .= "$ws    moose_with(qw(@does));" if @does;
			$pkg_really{$1} = $PKG = "${PKG}::$1";
			$ENDMATTER = '}';
		    };

            $line =~ s/^(\s*)grammar (\w+)\s+(.*?)\{/${1}{ package ${PKG}::$2;\n$1    use Moose ':all' => { -prefix => "moose_" };\n$1     my \$retree;/
                    and do {
			my $ws = $1;
			my $name = $2;
			my $is = $3;

			my @is;
			my @does;
			my @list = split ' ', $is;
			my $which;
			while (@list) {
			    my $next = shift @list;
			    if ($next eq 'is') {
				$which = \@is;
			    }
			    elsif ($next eq 'does') {
				$which = \@does;
			    }
			    else {
				push @$which, $pkg_really{$next} || $next;
			    }
			}
			push(@PKG, $PKG);
			push(@RETREE, $RETREE);
			$RETREE = {};
			$pkg_really{$name} = $PKG = "${PKG}::$name";
			$line .= "$ws    moose_extends(qw(@is));" if @is;
			$line .= "$ws    moose_with(qw(@does));" if @does;
			$line =~ s/${TOP}::$TOP/$TOP/g;
			$ENDMATTER = '}';
		    };

	    if ($line =~ s/^(\s*)role (\w+)(?:\[(.*?)\])?\s+(.*?)\{//) {
		my $ws = $1;
		my $name = $2;
		my $params = $3;
		my $is = $4;
		my @is;
		my @does;
		my @list = split ' ', $is;
		my $which;

		if ($params) {	# parametric type? resort to eval...
		    my $qp = '{ ' . $params . ' }';
		    $qp =~ s/(\$\w+)/'$1' => $1/g;
		    $line = <<"END";
${ws}{ package ${PKG}::$name;
$ws    sub __instantiate__ { my \$self = shift;
$ws        my ($params) = \@_;
$ws        my \$mangle = ::mangle($params);
$ws        my \$mixin = "${PKG}::${name}::" . \$mangle;
$ws        return \$mixin if \$INSTANTIATED{\$mixin}++;
$ws        ::deb("\t\tinstantiating \$mixin") if \$::DEBUG & DEBUG::mixins;
$ws        my \$eval = "package \$mixin" . q{;
$ws            use Moose::Role ':all' => { -prefix => "moose_" };
$ws            my \$retree;
$ws            sub _PARAMS { $qp }
END
		    $ENDMATTER = <<"END";
$ws        };
$ws        eval \$eval;
$ws        return \$mixin;
$ws    }
$ws}
END
		}
		else {
		    $line = <<"END";
${ws}{ package ${PKG}::$name;
$ws    use Moose::Role ':all' => { -prefix => "moose_" };
$ws    my \$retree;
END
		    $ENDMATTER = '}';
		}

		while (@list) {
		    my $next = shift @list;
		    if ($next eq 'is') {
			$which = \@is;
		    }
		    elsif ($next eq 'does') {
			$which = \@does;
		    }
		    else {
			push @$which, $pkg_really{$next} || "${PKG}::$next";
		    }
		}

		push(@PKG, $PKG);
		push(@RETREE, $RETREE);
		$RETREE = {};
		$pkg_really{$name} = $PKG = "${PKG}::$name";
		$line .= "$ws        moose_extends(qw(@is));\n" if @is;
		$line .= "$ws        moose_with(qw(@does));\n" if @does;
		$line =~ s/${TOP}::$TOP/$TOP/g;
		$out .= $line;
		next;
	    }

            $line =~ s/\(state %(\w+)\)/(state \$$1)->/;
            $line =~ s/(\S+) xx /($1) x /;
            $line =~ s/(\S+) xx /($1) x /;
            $line =~ s/ x \?/ x !!/;
            $line =~ s/\|%start/%start/;
            if ($line =~ s/^(\s*)method (\w+)\s*(.*?)\{/$1sub $2 { my \$self = shift; my $3= \@_; /) {
                $out .= "# $1method $2 $3\n";
                $line =~ s/Match //g;
                $line =~ s/Str //g;
                $line =~ s/my \(\) = \@_;//g;
                $line =~ s/my *= \@_;//g;
            }
            elsif ($line =~ s/^(\s*)sub (\w+)\s*(.*?)\{/$1sub $2 { my $3= \@_; /) {
                $line =~ s/Match //g;
                $line =~ s/Str //g;
                $line =~ s/my \(\) = \@_;//g;
                $line =~ s/\*\@/\@/;
                $line =~ s/my *= \@_;//g;
            }

            $out .= $line;
        }
    }
    dumpretree();

    print <<'END';
use 5.010;
use utf8;
# Emulate context vars by localizing 'our' vars living in main\n";
END

    for (sort keys(%OUR)) {
        s/:://;
        print "our $_;\n";
    }
    print <<'END';

our $moreinput;

our %INSTANTIATED;
require 'mangle.pl';

END

    print $out;
    print "\n1;\n# vim: sw=4 ft=perl\n";
}

sub dumpretree {
    if (%$RETREE) {
	$out .= "BEGIN {\n    \$retree = YAML::XS::Load(Encode::encode_utf8(<<'RETREE_END'));\n";
#	$out .= Encode::decode("utf8", Dump($RETREE)); # Syck
	$out .= Encode::decode_utf8(Dump($RETREE));
	$out .= "RETREE_END\n}\n";
    }
}

sub here {
    print STDERR +(caller(0))[3],": ",/^(.{0,20})/,"\n" if $TRACE;
}

#############################################3333
## Regex
#############################################3333

sub ws {
    return if $adverbs{s};  # meta whitespace parsed in atom
    for (;;) {
#	next if s/^(?!=[\0-~])\s+//;
        next if s/^[\x20\t\n\r]+//;
	last unless s/^#//;
        next if s/^\(.*?\)//s;
        next if s/^\{.*?\}//s;
        next if s/^\[.*?\]//s;
        next if s/^\<.*?\>//s;
        next if s/^.*\n//;
        last;
    }
}

sub wsany {
    for (;;) {
        next if s/^\s+//;
        next if s/^#\(.*?\)//s;
        next if s/^#\{.*?\}//s;
        next if s/^#\[.*?\]//s;
        next if s/^#\<.*?\>//s;
        next if s/^#.*\n//;
        last;
    }
}

sub regex {
    here();
    ws();
    local $STOP = shift;
    local %adverbs = %adverbs;

    my @decl;
    while (s/^\s*:(my|state|our|constant|temp|let)\b/$1/) {
        my $code = unbalanced(";");
        s/^;// or panic "Missing ;";
        push @decl, bless { text => $code, min => 0, max => 0, %adverbs }, "RE_decl";
    }

    my $od = first();
    return bless { decl => [@decl], re => $od, min => $od->{min} }, "RE_ast";
}

sub first {
    here();
    my @kids;
    my $min = 1_000_000_000;

    s/^\s*\|\|//;

    do {
        ws();
        my $k = every();
        push @kids, $k;
        my $kidmin = $k->{min};
        $min = $kidmin if $kidmin < $min;
        ws();
    } while s/^\|\|//;

    return $kids[0] if @kids == 1;
    return bless { zyg => [@kids], min => $min, %adverbs}, "RE_first";
}

sub every {
    here();
    my @kids;
    my $min = 0;

    do {
        ws();
        my $k = submatch();
        push @kids, $k;
        my $kidmin = $k->{min};
        $min = $kidmin if $kidmin > $min;
        ws();
    } while s/^\&\&//;

    return $kids[0] if @kids == 1;
    return bless { zyg => [@kids], min => $min, %adverbs }, "RE_every";
}

sub submatch {
    here();
    my @kids;

    do {
        ws();
        push @kids, any();
        ws();
    } while s/^\!?\~\~//;

    return $kids[0] if @kids == 1;
    return bless { zyg => [@kids], min => 0, %adverbs }, "RE_submatch";
}

sub any {
    here();
    my @kids;
    my $min = 1_000_000_000;
    local $ALTNAME = $NAME . '_' . $ALTNAMES++;
    my $name = $ALTNAME;

    s/^ \s*\| (?!\|) //x;

    do {
        ws();
        my $k = all();
        push @kids, $k;
        my $kidmin = $k->{min};
        $min = $kidmin if $kidmin < $min;
        ws();
    } while s/^ \| (?!\|) //x;

    return $kids[0] if @kids == 1;

    return bless { zyg => [@kids], min => $min, altname => $ALTNAME, name => $name, %adverbs },
              "RE_any";
}

sub all {
    here();
    my @kids;
    my $min = 0;

    do {
        ws();
        my $k = sequence();
        push @kids, $k;
        my $kidmin = $k->{min};
        warn "no kidmin $k\n" unless defined $kidmin;
        $min = $kidmin if $kidmin > $min;
        ws();
    } while s/^ \& (?!\&) //x;

    return $kids[0] if @kids == 1;
    return bless { zyg => [@kids], min => $min, %adverbs }, "RE_all";
}

sub sequence {
    here();
    my @kids;
    my $k;
    my $min = 0;
    my $lastws = 0;

    while ($k = quantified_atom()) {
        if ($lastws) {
            # optimize away any redundant ws
            $k->remove_leading_ws();
        }
        push(@kids, $k);
        $lastws = ref $k eq 'RE_method' && $k->{name} eq 'ws';
        my $kidmin = $k->{min};
        $min += $kidmin;
    }

    return $kids[0] if @kids == 1;
    return bless { zyg => [@kids], min => $min, %adverbs }, "RE_sequence";
}

sub quantified_atom {
    here();
    my $atom = atom();
    return unless defined $atom and $atom ne '';
    return $atom if $atom->{noquant};
    my $quant = quantifier();
    return $atom unless $quant;
    my $min = $atom->{min} * $quant->[3];
    return bless { atom => $atom, quant => $quant, min => $min },
        "RE_quantified_atom";
}

sub quantifier {
    if (s/^\s*(\*\*)([?!:+]?)// or
        s/^\s*(\*)([?!:+]?)// or
        s/^\s*(\+)([?!:+]?)// or
        s/^\s*(\?)([?!:+]?)//) {
        my ($q,$m) = ($1,$2);
        my $min = 0;
        if (not $m) {
            if ($adverbs{r}) {
                $m = ':';
            }
            else {
                $m = '!';
            }
        }
        elsif ($m eq '+') {
                $m = '!';
        }
        my $x = "";
        if ($q eq '**') {
            if (s/^\s*((\d+)(\.\.(\d+|\*))?)//) {
                $x = $1;
                $min = $2;
            }
            elsif (/^\s*\{/) {
                wsany();
                $x = block('thunk');
                $min = 0;
            }
            else {
                wsany();
                $x = atom();
                $min = 1;
            }
        }
        elsif ($q eq '+') {
            $min = 1;
        }
        ws();
        $MAYBACKTRACK = 1 unless $m eq ':';
        return [$q,$m,$x,$min];
    }
}

sub atom {
    here();
    if (@STUFFED) {
	return shift @STUFFED;
    }
    # unspace
    if (s/^\\\s/ /) {
        panic("Attempt to quote whitespace");
    }
    # sigspace
    if (/^[\s\#]/ and $adverbs{s}) {
        wsany();
        return bless { name => 'ws', nobind => 1, noquant => 1, min => 0, rest => '' },
            "RE_method";
    }
    return if /^ [\]&|] /x;   # XXX an approximation
    return if /^ \)[^>]/x;
    return if /^ (?:
        >(?!>) |
        !?~~
    )/x;
    return if /^ ( $STOP )/x;

    if (/^[*+?]/) { panic "quantifier quantifies nothing"; }

    if (s/^~//) {
	wsany();
	my $beg = length($all) - length($_);
	my $goal = quantified_atom();
	my $end = length($all) - length($_);
	my $goaltext = substr($all, $beg, $end - $beg);

	my $dba = $adverbs{dba} // $NAME;
	$dba =~ s/'/\\\'/g;
	my $failgoal = bless { name => 'FAILGOAL', rest => "($goaltext, '$dba',\$goalpos)", min => 0, nobind => 1 }, "RE_method";
	my $check = bless { zyg => [$goal, $failgoal], min => 1, %adverbs}, "RE_first";
	my $checkbrack = bless({ decl => [], re => $check, min => 1 }, "RE_bracket");

	wsany();

	my $nest = quantified_atom();

	@STUFFED = ($nest, $checkbrack);
        return bless { text => ':', min => 0, extra => "local \$::GOAL = $goaltext, my \$goalpos = \$C", %adverbs }, "RE_meta";
    }
    if (s/^ (\w+) (?! \s* [*+?]) //x) {
        my $word = $1;
        ws();
        return bless { text => $word, min => length($word), %adverbs }, "RE_string";
    }
    if (s/^ (\w) //x) {
        my $word = $1;
        ws();
        return bless { text => $word, min => length($word), %adverbs }, "RE_string";
    }

    if (s/^\{\*\}//) {
        my $meth = $NAME;
        my $tag = '';
        if (s/^(.*?)\s*#=\s+(.*)/$1/) {
            $tag = $2;
            $tag =~ s/(['\\])/\\$1/g;
            $tag = ", '$tag'";
        }
        ws();
        return bless { name => '_REDUCE', args => "\$S, '$meth'$tag", min => 0, max => 0},
                     "RE_method_internal";
    }
    if (/^\{/) {
        my $b = block('void');
        ws();
        return $b;
    }

    if (s/^\\//) { my $bs = backslash(); ws(); return $bs; }

    if (s/^\[//) {
        my $re = regex('\\]');
        s/^\]// or panic "Missing ]";
        ws();
        return bless $re, "RE_bracket";
    }

    if (s/^\(//) {
        my $re = do { local $PAREN = 0; regex('\\)') };
        s/^\)// or panic "Missing )";
        ws();
        $re = bless $re, "RE_paren";
        if (not $PARSEBIND) {  # XXX leaves quantifier outside?
            $re = bless { var => $PAREN++, atom => $re, min => $re->{min} },
                "RE_bindpos";
        }
        return $re;
    }

    if (s/^ : (!?) (\w+)//x) {
        my $not = $1 ne '';
        my $adverb = $2;
	$adverb =~ s/^sigspace/s/;
	$adverb =~ s/^ratchet/r/;
        
        if (m/^\(/) {
	    pos($_) = 0;
	    my $code = extract_bracketed($_,'(q)');
	    $code = ::un6($code);
            $adverbs{$adverb} = $code;
	    ws();
	    if ($adverb eq 'lang') {
		$code = "my \$newlang = $code;  \$C = \$C->cursor_fresh(\$newlang); ";
		return bless { text => $code, min => 0, max => 0, noquant => 1, %adverbs }, "RE_decl";
	    }
	    elsif ($adverb eq 'dba') {
		$adverbs{$adverb} = eval $code;
	    }
        }
	elsif (s/^<(.*?)>//) {
            $adverbs{$adverb} = $1;
	}
        else {
            $adverbs{$adverb} = 0+!$not;
        }
        ws();

        return quantified_atom();
    }

    # check weird angles before assertions

    if (s/^(<<|>>|«|»)//) {
        my $boundary = $1;
        ws();
        return bless { text => $boundary, min => 0, %adverbs }, "RE_meta";
    }

    if (s/^(::>)//) {
        my $then = $1;
        ws();
        return bless { text => $then, min => 0, %adverbs }, "RE_meta";
    }

    if (s/^(<(\.\.\.|!!!|\?\?\?)>)//) {
        my $notyet = $1;
        ws();
        return bless { text => $notyet, min => 0, %adverbs }, "RE_meta";
    }

    if (s/^(<\(|\)>)//) {
        my $boundary = $1;
        ws();
        return bless { text => $boundary, min => 0, %adverbs }, "RE_meta";
    }

    if (s/^(<~~>)//) {
	my $recurse = $1;
        ws();
        return bless { text => $recurse, min => 0, %adverbs }, "RE_meta";
    }

    if (/^<\s/) {
        my $re = unbalanced(">");
        s/^>// or panic "Missing >";
        my @elems = split(' ', $re);
        shift @elems;
        my $min = 1_000_000_000;
        for (@elems) { $min = length($_) if length($_) < $min }
        $re .= '>';
        ws();
        return bless { text => $re, min => $min, %adverbs }, "RE_qw";
    }

    # assertions

    s/^<(\w+)=/\$<$1>=</;
    if (s/^<//) {
        my $re = assertion();
        ws();
        return $re;
    }

    # now the rest of the metas

    if (s/^'//) {
        my $re = unbalanced("'");
        s/^'// or panic "Missing '";
	$re =~ s/\\(\\|')/$1/g;
        ws();
        return bless { text => $re, min => length($re), %adverbs }, "RE_string";
    }
    if (s/^"//) {
        my $re = unbalanced('"');
        s/^"// or panic 'Missing "';
        my $tmp = $re;
        $tmp =~ s/\\\w/X/g;    # XXX ignoring \x and \o for now
        $tmp =~ s/\$\w+//g;    # assume vars interpolate nothing
        ws();
        return bless { text => $re, min => length($tmp), %adverbs }, "RE_double";
    }

    if (/^[\$\@\%]/) {
        my $code;
        if (/^[\$\@\%]</) {
            $code = unbalanced('>');
            s/^>// or panic "Missing >";
            $code .= '>';
        }
        if (s/^([\$\@\%][.!?*+]?\w+)//) {
            $code = $1;
        }
        if (defined $code) {
            ws();
            if (s/^\s*=\s*//) {
                ws();
                local $PARSEBIND = 1;
                my $atom = quantified_atom(@_);
                ws();
                if ($code =~ /[\$\@%]<(.*?)>/) {
                    return bless { var => $1,
                                   atom => $atom,
                                   min => $atom->{min},
				   %adverbs
				}, "RE_bindnamed";
                }
                return bless { var => $code, atom => $atom, min => $atom->{min}, %adverbs }, "RE_bindvar";
            }
            else {
                return bless { var => $code, min => 0, %adverbs }, "RE_var";
            }
        }
    }

    # must follow variables
    if (s/^([\^\$]{1,2})//) {
        my $anchor = $1;
        ws();
        return bless { text => $anchor, min => 0, %adverbs }, "RE_meta";
    }
    if (s/^(:+)//) {
        my $colons = $1;
        ws();
        return bless { text => $colons, min => 0, %adverbs }, "RE_meta";
    }
    if (s/^(\.\*\??)//) {
	my $scan = $1;
        ws();
        return bless { text => $scan, min => 1, %adverbs }, "RE_meta";
    }
    if (s/^\.//) {
        ws();
        return bless { text => '.', min => 1, %adverbs }, "RE_meta";
    }

    panic "unrecognized metacharacter @{[ substr($_,0,1) ]}";
}

sub backslash {
    my $ch = substr($_,0,1,"");
    
    if ($ch =~ /^\w$/) {
        if ($ch =~ /^[ftnr]/) {
            return bless { text => '\\' . $ch, min => 1, %adverbs  }, "RE_double";
        }
        if ($ch eq 'x') {
            s/^\[?([0-9a-fA-f]*)\]?//;
            return bless { text => '\\x' . $1, min => 1, %adverbs  }, "RE_double";
        }
        if ($ch eq 'o') {
            s/^\[?([0-7]*)\]?//;
            return bless { text => '\\o' . $1, min => 1, %adverbs  }, "RE_double";
        }
        if ($ch =~ /^[hvdswHVDSWNRTBF]/) {
            return bless { text => "\\$ch", min => 1, %adverbs  }, "RE_meta";
        }
        panic "Unrecognized \\$ch";
    }
    if ($ch eq '\\') {
        return bless { text => '\\', min => 1, %adverbs  }, "RE_string";
    }
    return bless { text => $ch, min => 1, %adverbs }, "RE_string";
}

sub assertion {
    here();
    my $assert = substr($_,0,1);

    if (s/^[!?]//) {
        my $rest = assertion();
        $rest->{nobind} = 1;
        return bless { assert => $assert, re => $rest, min => 0 },
            "RE_assertion";
    }
    if (s/^>//) {
        return bless { min => 0, %adverbs }, "RE_noop";
    }

    if (/^[+-]?\[/) {
        my $cclass = unbalanced(']>');
        s/^]>// or panic "Missing ]>";
        $cclass =~ s/\\x([0-9a-fA-F]{3,4})/\\x\{$1\}/g;
        return bless { text => $cclass . ']', min => 1, %adverbs }, "RE_cclass";
    }

    if (s/^\.//) {
        my $rest = assertion();
        $rest->{nobind} = 1;
        return $rest;
    }

    if (s/^([a-zA-Z]\w*(?:\:\:\w+)*)//) {
        my $word = $1;
        my $ch = substr($_,0,1);
        if ($ch eq '>') {
            s/^>// or panic "Missing >";
            if ($word eq 'sym') {
		if ($ENDSYM) {
		    s/^/<.$ENDSYM>/;	# hopefully checks word boundary
		}
            }
            return bless { name => $word, min => 12345, rest => '', %adverbs }, "RE_method";
        }
        if ($ch eq ':') {
            my $code = code('>');
            s/^>// or panic "Missing >";
	    $code =~ s/:\s+(.*)$/($1)/s;
            return bless { name => $word, rest => $code, min => 0 },
                "RE_method";
        }
        if ($ch eq '(') {
            my $code = code('\\)>');
            s/^\)>// or panic "Missing )>";
            $code .= ')';
            return bless { name => $word, rest => $code, min => 0 },
                "RE_method";
        }
        s/^\s*//;
        my $re = regex('\\>[^>]');
        s/^>// or panic "Missing >";
        return bless { name => $word, re => $re, min => 0, %adverbs }, "RE_method_re";
    }

    if (/^[\$\@\%]/) {
        my $code = code('>');
        s/^>// or panic "Missing >";
        if ($code =~ s/(\(.*\))//) {
            return bless { name => $code, rest => $1, min => 0, %adverbs }, "RE_method";
        }
        else {
            return bless { name => $code, min => 0, rest => '', %adverbs }, "RE_method";
        }
    }

    if (/^\{/) {
        my $b = block('bool');
        s/^>// or panic "Missing >";
        ws();
        return $b;
    }

}

sub block {
    # XXX
    my $context = shift;
    s/^({+)//;
    my $term = '\\}' x length($1);
    my $block = code($term);
    s/^$term// or panic "Missing }" ;
    return bless { text => $block, context => $context, min => 0, %adverbs }, "RE_block";
}

sub code {
    # XXX
    my $code = unbalanced(@_);
    return $code;
}

sub unbalanced {
    my $terminator = shift;
    s/^ ( (\\. | . )*? ) (?=$terminator)//sx;
    return $1;
}

##########################################################

{ package REbase;
    sub walk {
        my $self = shift;
        my $result = "";
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                my $x = $kid->walk(@_);
                $result .= $x if defined $x;
            }
        }
        else {
            return ref $self;
        }
        return $result;
    }

    sub bind { my $self = shift;
	my $re = shift;
	return $re unless @BINDINGS;
	my $ratchet = $MAYBACKTRACK ? '' : 'r';
	$re = "\$C->_SUBSUME$ratchet([" .
	    join(',', map {"'$_'"} @BINDINGS) .
	    "], sub {\n" . ::indent("my \$C = shift;\n" . $re, 2) . "\n  })";
	@BINDINGS = ();
	$re;
    }

    sub remove_leading_ws { }   # this tree node not interested
    sub remember_alts { }
}

{ package RE_ast; use base "REbase";
    sub walk {
        my $self = shift;
        if ($$self{decl}) {
            for my $decl (@{$$self{decl}}) {
                push @DECL, "    " . $decl->walk(@_) . "\n";
            }
        }
        if ($$self{re}) {
            return $$self{re}->walk(@_);
        }
    }
    sub remember_alts {
        my $self = shift;
        if ($$self{re}) {
            $$self{re}->remember_alts(@_);
        }
    }
}

{ package RE_adverb; use base "REbase";
}

{ package RE_assertion; use base "REbase";
    sub walk {
        my $self = shift;
        local($PURE);
        if ($$self{assert} eq '!') {
            my $re = $$self{re}->walk(@_);
            $self->bind("\$C->_NOTBEFORE( sub { my \$C=shift;\n" . ::indent($re) . "\n})");
        }
        else {
            my $re = $$self{re}->walk(@_);
            return $re if $re =~ /^\$C->before/;
            $self->bind("\$C->before( sub { my \$C=shift;\n" . ::indent($re) . "\n})");
        }
    }

    sub remember_alts {
        my $self = shift;
        $$self{re}->remember_alts(@_);
    }
}

{ package RE_assertvar; use base "REbase";
}

{ package RE_block; use base "REbase";
    sub walk {
        my $self = shift;
        local $NEEDMATCH = 0;
        %NEEDSEMI = ();
        my $text = '';
        for my $line (split /^/,$$self{text}) {
            if ($line =~ /^(\s*).*?given/) {
                my $len = length($1);
                $NEEDSEMI{$len} = 1;
            }
            elsif ($line =~ /^(\s*)}\n/) {
                my $len = length($1);
                if (delete $NEEDSEMI{$len}) {
                    $line =~ s/}/};/;
                }
            }
            $text .= $line;
        }
        $text = ::un6($text) // '';
        my $ctx = $$self{context};
        $text = 'my $M = $C; ' . $text . ';' if $NEEDMATCH;
        if ($text =~ s/\bmake\b/make \$C/g) {  # XXX hack, avoid using $<make>
            "do {\n" . ::indent($text) . "\n}";
        }
        elsif ($ctx eq 'void') {
            $PURE = 0;
            "scalar(do {\n" . ::indent($text) . "\n}, \$C)";
        }
        elsif ($ctx eq 'bool') {
            "((\$C) x !!do {\n" . ::indent($text) . "\n})";
        }
        else {
            $PURE = 0;
            " sub { my \$C=shift;\n" . ::indent($text) . "\n}";
        }
    }
}

{ package RE_bindvar; use base "REbase";
    sub walk {
        my $self = shift;
        my $var = $$self{var};
        my $re = $$self{atom}->walk(@_);
        "($var = $re)";	# doesn't do "let" semantics yet
    }
}

{ package RE_bindnamed; use base "REbase";
    sub walk {
        my $self = shift;
        my $var = $$self{var};
	push @BINDINGS, $var;
	$BINDINGS{$var} += $BINDNUM;
        my $re = ::indent($$self{atom}->walk(@_));
        $re;
    }

    sub remember_alts {
        my $self = shift;
        $$self{atom}->remember_alts(@_);
    }
}

{ package RE_bindpos; use base "REbase";
    sub walk {
        my $self = shift;
        my $var = $$self{var};
	push @BINDINGS, $var;
	$BINDINGS{$var} += $BINDNUM;
        my $re = ::indent($$self{atom}->walk(@_));
        $re;
    }

    sub remember_alts {
        my $self = shift;
        $$self{atom}->remember_alts(@_);
    }
}

{ package RE_bracket; use base "REbase";
    sub walk {
        my $self = shift;
	my $re;
	{
            local $MAYBACKTRACK = $MAYBACKTRACK;
	    local @BINDINGS;
	    $re = ::indent($$self{re}->walk(@_));
	}
	my $ratchet = $MAYBACKTRACK ? '' : 'r';
        $re = "\$C->_BRACKET$ratchet(sub {\n  my \$C=shift;\n" . $re . "\n})";
	$self->bind($re);
    }

    sub remove_leading_ws {
        my $self = shift;
        my $re = $$self{re};
        $re->remove_leading_ws();
    }

    sub remember_alts {
        my $self = shift;
        $$self{re}->remember_alts(@_);
    }

}

{ package RE_cclass; use base "REbase";
    sub walk {
        my $self = shift;
        my $text = $$self{text};
        $text =~ s!(\/|\\\/)!\\$1!g;
        $text =~ s/\s//g;
        $text =~ s/\.\./-/g;
	$text =~ s/^-\[/[^/;
	$text = "(?<=$text)" if $REV;
	if ($$self{i}) {
	    $self->bind("\$C->_PATTERN(qr/\\G(?i:$text)/)");
	}
	else {
	    $self->bind("\$C->_PATTERN(qr/\\G$text/)");
	}
    }
}

{ package RE_decl; use base "REbase";
    sub walk {
        my $self = shift;
        local $NEEDMATCH = 0;
        my $text = ::un6($$self{text} . ';');
        $text = 'my $M = $C; ' . $text . '; ' if $NEEDMATCH;
        $text;
    }
}

{ package RE_double; use base "REbase";
    sub walk {
        my $self = shift;
        my $text = $$self{text};
	$text = "(?<=$text)" if $REV;
	if ($$self{i}) {
	    $self->bind('$C->_PATTERN(qr/\\G(?i:' . $text . ')/")');
	}
	else {
	    $self->bind('$C->_EXACT("' . $text . '")');
	}
    }
}

{ package RE_string; use base "REbase";
    sub walk {
        my $self = shift;
	if ($$self{i}) {
            my $text = quotemeta($$self{text});
            $text = "(?<=$text)" if $REV;
	    '$C->_PATTERN(qr/\\G(?i:' . $text . ')/)';
	}
	else {
            my $text = $$self{text};
            $text =~ s/([\\'])/\\$1/g;
            "\$C->_EXACT$REV('$text')";
    #	    "\$C->_PATTERN(qr/\\G$text/)";
#	    my $l = length($text);
#	    "(substr(\$\$buf, \$C->{_pos}, $l) eq '" . $text .  "' ? \$C->cursor(\$C->{_pos} + $l) : ())"
	}
    }
}

{ package RE_meta; use base "REbase";
    sub walk {
        my $self = shift;
        my $text = $$self{text};
        my $not = 0;
        my $code = "";
        if ($text =~ /^(\\[A-Z])(.*)/) {
            $text = lc($1) . $2;
            $not = 1;
        }
        if ($text eq '.') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=(?s:.))/)";
	    }
	    else {
		$code = "\$C->cursor_incr()";
	    }
#            $code = "\$C->_ANY$REV()";
        }
        elsif ($text eq '.*') {
#	    if ($REV) {
#		$code = "\$C->_PATTERN(qr/\\G(?<=.*)/)";
#	    }
#	    else {
#		$code = "\$C->_PATTERN(qr/\\G.*/)";
#	    }
            $code = "\$C->_SCANg$REV()";
        }
        elsif ($text eq '.*?') {
#	    if ($REV) {
#		$code = "\$C->_PATTERN(qr/\\G(?<=.*?)/)";
#	    }
#	    else {
#		$code = "\$C->_PATTERN(qr/\\G.*?/)";
#	    }
            $code = "\$C->_SCANf$REV()";
            $MAYBACKTRACK = 1;
        }
        elsif ($text eq '^') {
	    $code = "\$C->_PATTERN(qr/\\G\\A/)";
#            $code = "\$C->_BOS$REV()";
        }
        elsif ($text eq '^^') {
	    $code = "\$C->_PATTERN(qr/\\G(?m:^)/)";
#            $code = "\$C->_BOL$REV()";
        }
        elsif ($text eq '$') {
	    $code = "\$C->_PATTERN(qr/\\G\\z/)";
#            $code = "\$C->_EOS$REV()";
        }
        elsif ($text eq '$$') {
	    $code = "\$C->_PATTERN(qr/\\G(?m:\$)/)";
#            $code = "\$C->_EOL$REV()";
        }
        elsif ($text eq ':') {
	    my $extra = $self->{extra} || '';
            $code = "(($extra), \$C)[-1]";
        }
        elsif ($text eq '::') {
            $PURE = 0;
            $code = "\$C->_COMMITLTM$REV()";
        }
        elsif ($text eq '::>') {
            $PURE = 0;
            $code = "\$C->_COMMITBRANCH$REV()";
        }
        elsif ($text eq ':::') {
            $PURE = 0;
            $code = "\$C->_COMMITRULE$REV()";
        }
        elsif ($text eq '\\d') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=\\d)/)";
	    }
	    else {
		$code = "\$C->_PATTERN(qr/\\G\\d/)";
	    }
#            $code = "\$C->_DIGIT$REV()";
        }
        elsif ($text eq '\\w') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=\\w)/)";
	    }
	    else {
		$code = "\$C->_PATTERN(qr/\\G\\w/)";
	    }
#           $code = "\$C->_ALNUM$REV()";
        }
        elsif ($text eq '\\s') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=\\s)/)";
	    }
	    else {
		$code = "\$C->_PATTERN(qr/\\G\\s/)";
	    }
#            $code = "\$C->_SPACE$REV()";
        }
        elsif ($text eq '\\h') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=[\\x20\\t\\r])/)";
	    }
	    else {
		$code = "\$C->_PATTERN(qr/\\G[\\x20\\t\\r]/)";
	    }
#            $code = "\$C->_HSPACE$REV()";
        }
        elsif ($text eq '\\v') {
	    if ($REV) {
		$code = "\$C->_PATTERN(qr/\\G(?<=[\\n])/)";
	    }
	    else {
		$code = "\$C->_PATTERN(qr/\\G[\\n]/)";
	    }
#            $code = "\$C->_VSPACE$REV()";
        }
        elsif ($text eq '»') {
	    $code = "\$C->_PATTERN(qr/\\G\\b/)";
#            $code = "\$C->_RIGHTWB$REV()";
        }
        elsif ($text eq '«') {
	    $code = "\$C->_PATTERN(qr/\\G\\b/)";
#            $code = "\$C->_LEFTWB$REV()";
        }
        elsif ($text eq '>>') {
            $code = "\$C->_RIGHTWB$REV()";
        }
        elsif ($text eq '<<') {
            $code = "\$C->_LEFTWB$REV()";
        }
        elsif ($text eq '<(') {
            $code = "\$C->_LEFTRESULT$REV()";
        }
        elsif ($text eq ')>') {
            $code = "\$C->_RIGHTRESULT$REV()";
        }
        elsif ($text eq '<~~>') {
            $code = "\$C->$NAME()";
        }
        else {
            $code = "\$C->_EXACT$REV(\"$text\")";
        }
        if ($not) { # XXX or maybe just .NOT on the end...
            $PURE = 0;
            $code = "\$C->_NOTCHAR( sub { my \$C=shift;\n" . ::indent($code) . "\n})";
        }
        $code;
    }
}

{ package RE_method; use base "REbase";
    sub walk {
        my $self = shift;
        local $NEEDMATCH = 0;
        my $rest = ::un6($$self{rest}) // '';
        my $name = $$self{name};
	warn ::Dump(%adverbs) if $REV;
        ::panic("Can't reverse $name") if $REV;
        $PURE = 0 if $impure{$name};
	my $re;

        if ($name eq "sym") {
            $$self{sym} = $SYM;
            $$self{endsym} = $ENDSYM if $ENDSYM;
	    if ($$self{i}) {
		return "\$C->_PATTERN(qr/\\G(?i:" . quotemeta($SYM) . ")/)";
	    }
	    else {
		return "\$C->_PATTERN(qr/\\G" . quotemeta($SYM) . "/)";
	    }
            return $re = '$C->_SYM($sym, ' . ($$self{i}//0) . ')';	# could pass endsym too here...
        }
        elsif ($name eq "alpha") {
            return "\$C->_PATTERN(qr/\\G[_[:alpha:]]/)";
        }
        elsif ($name eq "_ALNUM") {
            return "\$C->_PATTERN(qr/\\G\\w/)";
        }
#        elsif ($name eq "ws") {
#            return "\$C->_PATTERN(qr/\\G(?{ \$C = \$C->ws; pos(\$_) = \$C->{_pos} })/)";
#        }
        elsif ($name eq "nextsame") {
            $NEEDORIGARGS++;
            $re = '$self->SUPER::' . $NAME . '(@origargs)';
        }
        elsif ($name =~ /^\w/) {
            $re = '$C->' . $name . $rest;
        }
        else {
	    $name = ::un6($name);
            $re = <<"END";
do {
  if (not $name) {
    \$C;
  }
  elsif (ref $name eq 'Regexp') {
    if (\$::ORIG =~ m/$name/gc) {
      \$C->cursor(\$+[0]);
    }
    else {
      ();
    }
  }
  else {
    \$C->$name$rest;
  }
}
END
        }
	if ($name =~ /^\w/ and not $self->{nobind}) {
	    push @BINDINGS, $name;
	    $BINDINGS{$name} += $BINDNUM;
	}
        $re = 'do { my $M = $C;' . "\n" . ::indent($re) . "\n; }" if $NEEDMATCH;
	$self->bind($re);
    }
}

{ package RE_method_internal; use base "REbase";
    sub walk {
        my $self = shift;
        my $name = $$self{name};
        local $NEEDMATCH = 0;
        my $args = ::un6($$self{args});
        ::panic("Can't reverse $name") if $REV;
        $PURE = 0 if $impure{$name};

        my $re = '$C->' . $name . "($args)";
        $re = 'do { my $M = $C;' . "\n" . ::indent($re) . "\n; }" if $NEEDMATCH;
        $re;
    }
}

{ package RE_method_re; use base "REbase";
    sub walk {
        my $self = shift;
        my $re = $$self{re};
        my $name = $$self{name};
        ::panic("Can't reverse $name") if $REV and $name ne 'before';
        local $REV = '';
        $PURE = 0 if $impure{$name};
        local $REV = '_rev' if $name eq 'after';
	{
	    local @BINDINGS;
	    local %BINDINGS;
	    $re = ::indent($re->walk(@_));
	    if (%BINDINGS) {
		for my $binding ( keys %BINDINGS ) {
		    next unless $BINDINGS{$binding} > 1;
		    my $re = <<"END" . $re;
	\$C->{'$binding'} = [];
END
		}
	    }
	}
        $REV = '';

        $re = '$C->' . $name . "(sub { my \$C=shift;\n" . ::indent($re) . "\n})";
	if ($name =~ /^\w/ and not $self->{nobind}) {
	    push @BINDINGS, $name;
	    $BINDINGS{$name} += $BINDNUM;
	}
	$self->bind($re);
    }

    sub remember_alts {
        my $self = shift;
        my $re = $$self{re};
        $re->remember_alts(@_);
    }
}

{ package RE_noop; use base "REbase";
    sub walk {
        my $self = shift;
        '$C';
    }
}

{ package RE_every; use base "REbase";
    sub walk {
        my $self = shift;
        my @result;
        if ($$self{zyg}) {
            $PURE = 0 if @{$$self{zyg}} > 1;
            foreach my $kid (@{$$self{zyg}}) {
                push @result, $kid->walk(@_);
            }
        }
        if (@result == 1) {
            $result[0];
        }
        else {
            ::panic("Can't reverse serial conjunction") if $REV;
            my $result = ::indent(join("\nSAME\n", @result));
            $result;
        }
    }

    sub remove_leading_ws {
        my $self = shift;
        for my $kid (@{$$self{zyg}}) {
            $kid->remove_leading_ws();
        }
    }

    sub remember_alts {
        my $self = shift;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }

}

{ package RE_first; use base "REbase";
    sub walk {
        my $self = shift;
        my @result;
        if ($$self{zyg}) {
	    my %B = %BINDINGS;
            $PURE = 0 if @{$$self{zyg}} > 1;
            foreach my $kid (@{$$self{zyg}}) {
		local %BINDINGS;
                push @result, $kid->walk(@_);
		for my $b (keys %BINDINGS) {
		    $B{$b} = 2 if $BINDINGS{$b} > 1 or $B{$b};
		}
            }
	    %BINDINGS = %B;
        }
        if (@result == 1) {
            $result[0];
        }
        else {
            ::panic("Can't reverse serial disjunction") if $REV;
            for (@result) { $_ = ::indent($_); s/^ */do {\n  push \@gather, /; }
            my $result = "do {\n  my \$C = \$C->cursor_xact('ALT ||');\n  my \$xact = \$C->xact;\n  my \@gather;\n" .
                            ::indent(join("\n}\nor \$xact->[-2] or\n", @result)) .
                          "};\n  \@gather;\n}";
            $result;
        }
    }

    sub remove_leading_ws {
        my $self = shift;
        for my $kid (@{$$self{zyg}}) {
            $kid->remove_leading_ws();
        }
    }

    sub remember_alts {
        my $self = shift;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }
}

{ package RE_paren; use base "REbase";
    sub walk {
        my $self = shift;
	my $re;
	{
	    local @BINDINGS;
	    local %BINDINGS;
	    $re = ::indent($$self{re}->walk(@_));
	    if (%BINDINGS) {
		for my $binding ( keys %BINDINGS ) {
		    next unless $BINDINGS{$binding} > 1;
		    my $re = <<"END" . $re;
	\$C->{'$binding'} = [];
END
		}
	    }
	}
        $re = "do { \$C->_${REV}PAREN( sub { my \$C=shift;\n" . ::indent($re) . "\n})}";
	$self->bind($re);
    }

    # yes, () would capture the ws, but we're guaranteed to be past it already
    sub remove_leading_ws {
        my $self = shift;
        my $re = $$self{re};
        $re->remove_leading_ws();
    }

    sub remember_alts {
        my $self = shift;
        my $re = $$self{re};
        $re->remember_alts();
    }
}

{ package RE_quantified_atom; use base "REbase";
    sub walk {
        my $self = shift;
        my $result;
	local $BINDNUM = 2;
        #warn ::Dump($self);
        #warn $$self{quant},"\n";
        if (ref $$self{atom}) {
            my $quant = "";
            my $rep = "_REP";
            my $q = $$self{quant};
	    my $atom = $$self{atom}->walk(@_);
	    if ($q) {
		if ($atom =~ m{ ^ \$C->_PATTERN\(qr/\\G(.*?)/\) $ }sx ) {
		    my $a = "(?:$1)";
		    my ($qfer,$how,$rest) = @{$$self{quant}};
		    my $h = $how eq '!' ? '' :
			    $how eq '?' ? '?' :
					  '+';
		    if ($how eq '?' or $REV) {
			;
		    }
		    elsif ($qfer eq '**') {
			$h = $how eq '!' ? 'g' :
			     $how eq '?' ? 'f' :
					   'r';
			if (ref $rest) {
			    if (ref $rest eq "RE_block") {
				$PURE = 0;
				$rep = "_REPINDIRECT$REV";
				$rest = $rest->walk();
			    }
			    else {
				$rep = "_REPSEP$REV";
				$rest = " sub { my \$C=shift;\n" . ::indent($rest->walk()) . "\n}";
			    }
			}
			else {
			    $PURE = 0 if $rest =~ /^0/;
			    $rest = "'$rest'";
			}
			$quant = "\$C->$rep$h( $rest, ";
			return $quant . "sub { my \$C=shift;\n" . ::indent($atom) . "\n})";
		    }
		    else {
			$PURE = 0;
			return "\$C->_PATTERN\(qr/\\G($a$qfer$h)/\)";
		    }
		}

		my ($qfer,$how,$rest) = @{$$self{quant}};
		my $h = $how eq '!' ? 'g' :
			$how eq '?' ? 'f' :
				      'r';
		if ($qfer eq '*') {
		    $PURE = 0;
		    $quant = "\$C->_STAR$h$REV(";
		}
		elsif ($qfer eq '+') {
		    $quant = "\$C->_PLUS$h$REV(";
		}
		elsif ($qfer eq '?') {
		    $PURE = 0;
		    $quant = "\$C->_OPT$h$REV(";
		}
		elsif ($qfer eq '**') {
		    if (ref $rest) {
			if (ref $rest eq "RE_block") {
			    $PURE = 0;
			    $rep = "_REPINDIRECT$REV";
			    $rest = $rest->walk();
			}
			else {
			    $rep = "_REPSEP$REV";
			    $rest = " sub { my \$C=shift;\n" . ::indent($rest->walk()) . "\n}";
			}
		    }
		    else {
			$PURE = 0 if $rest =~ /^0/;
			$rest = "'$rest'";
		    }
		    $quant = "\$C->$rep$h( $rest, ";
		}
		return $quant . "sub { my \$C=shift;\n" . ::indent($atom) . "\n})";
	    }
            else {
                return $atom;
            }
        }
        else {
            return '"' . $$self{atom} . '"';
        }
        $result;
    }

    sub remember_alts {
        my $self = shift;
        if (ref $$self{atom}) {
            $$self{atom}->remember_alts(@_);
            if ($$self{quant}) {
                my ($qfer,$how,$rest) = @{$$self{quant}};
                if ($qfer eq '**' and ref $rest) {
                    $rest->remember_alts();
                }
            }
        }
    }
}

{ package RE_qw; use base "REbase";
    sub walk {
        my $self = shift;
        $self->bind("\$C->_ARRAY$REV( qw$$self{text} )");
    }
}

{ package RE_sequence; use base "REbase";
    sub wrapone {
        my ($outer, $inner) = @_;
        if ($MAYBACKTRACK) {
            "Cursor::lazymap(sub {\n  my \$C=\$_[0];\n" .
                ::indent($inner) .
            "\n}, $outer)";
        }
        else {
	    my $oi = $outer . $inner;
	    if ($oi =~ s{ ^ \$C->_PATTERN\(qr/\\G(.*?)/\) \$C->_PATTERN\(qr/\\G(.*?)/\) $ }{\$C->_PATTERN(qr/\\G$1$2/)}sx) {
		$oi;
	    }
	    else {
		my $in = ::indent($inner,2);
		substr(<<"END",0,-1);
do {
  if (my (\$C) = ($outer)) {
$in;
  }
  else {
    ();
  }
}
END

#               "map({ my \$C=\$_;\n" .
#                   ::indent($inner) .
#               "\n} ($outer)[0])";
	    }
        }
    }

    sub walk {
        my $self = shift;
        my @result;
        my @decl;
        if ($$self{zyg}) {
            my @kids = @{$$self{zyg}};

            while (@kids and ref $kids[0] eq 'RE_decl') {
                push @decl, shift(@kids)->walk(@_);
            }

            @kids = reverse @kids if $REV;
            foreach my $kid (@kids) {
                my $r = $kid->walk(@_);
                push @result, $r;
            }
        }
        my $result = pop @result;
        for (reverse @result) {
            $result = wrapone($_,$result);
        }
        join('', @decl, $result || '');
    }

    sub remove_leading_ws {
        my $self = shift;
        if ($$self{zyg}) {
            my @kids = @{$$self{zyg}};

            shift(@kids) while
                @kids and
                ref $kids[0] eq 'RE_method' and
                $kids[0]->{name} eq 'ws';

            $kids[0]->remove_leading_ws() if @kids;
            @{$$self{zyg}} = @kids;
        }
    }

    sub remember_alts {
        my $self = shift;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }
}

{ package RE_submatch; use base "REbase";
    sub walk {
        my $self = shift;
        my @result;
        if ($$self{zyg}) {
            $PURE = 0 if @{$$self{zyg}} > 1;
            foreach my $kid (@{$$self{zyg}}) {
                push @result, $kid->walk(@_);
            }
        }
        if (@result == 1) {
            $result[0];
        }
        else {
            ::panic("Can't reverse submatch") if $REV;
            my $against = shift @result;
            my $pattern = ::indent(shift @result);
            $against =~ s/BACK//;
            $against .= "";
            my $result = "\$C->SUBMATCH( $against, sub {\n$pattern\n})";
            $result;
        }
    }

    sub remember_alts {
        my $self = shift;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }
}

{ package RE_all; use base "REbase";
    sub walk {
        my $self = shift;
        my @result;
        if ($$self{zyg}) {
            $PURE = 0 if @{$$self{zyg}} > 1;
            foreach my $kid (@{$$self{zyg}}) {
                push @result, $kid->walk(@_);
            }
        }
        if (@result == 1) {
            $result[0];
        }
        else {
            my $result = ::indent(join("\nSAMEwith\n", @result));
            $result;
        }
    }

    sub remove_leading_ws {
        my $self = shift;
        for my $kid (@{$$self{zyg}}) {
            $kid->remove_leading_ws();
        }
    }

    sub remember_alts {
        my $self = shift;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }
}

{ package RE_any; use base "REbase";
    sub walk {
        my $self = shift;
        my @result;
        my $alt = 0;
        my $altname = $self->{altname};
        if ($$self{zyg}) {
            $PURE = 0 if @{$$self{zyg}} > 1;
	    my %B = %BINDINGS;
            for my $kid (@{$$self{zyg}}) {
                local $PURE = 1;
		local %BINDINGS;
                my $r = $kid->walk(@_);
		for my $b (keys %BINDINGS) {
		    $B{$b} = 2 if $BINDINGS{$b} > 1 or $B{$b};
		}
#                if ($r and $r =~ /^\$C->(\w+)/) {
#                    my $name = $1;
#                    if (my $p = $fixedprefix{$name}) {
#                        $r = "\$C->_EQ(\$C->{pos}, $p) && " . $r;
#                    }
#                }
                push @result, $r;
                $kid->{alt} = $altname . ' ' . $alt++;
            }
	    %BINDINGS = %B;
        }
        if (@result == 1) {
            $result[0];
        }
        else {
            for (@result) { $_ = "sub { my \$C=shift;\n" . ::indent($_) . "\n}," }
            my $policy;
            if ($failover) {
                die "failover no longer implemented";
                $policy = <<"END"
        \@try = @{[ '0..' . ($alt-1) ]};
        unshift \@try, splice(\@try,\$try,1) if \$tag eq '$altname';
        splice(\@try,1,0,\$relex) if \$relex;
END
            }
            else {
                $policy = <<"END"
        \@try = \$tag eq '$altname' ? (\$try,\$relex) : ();
END
            }
            my $result = <<"END";
do {
  my \@result = do {
    my (\$tag, \$try);
    my \@try;
    my \$relex;

    my \$fate;
    my \$x;
    if (\$fate = \$C->{'_fate'} and \$fate->[1] eq '$altname') {
        \$C->deb("Fate passed to $altname: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
        (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
        \@try = (\$try);
        \$x = 'ALT $altname';    # some outer ltm is controlling us
    }
    else {
        \$x = 'ALTLTM $altname'; # we are top level ltm
    }
    my \$C = \$C->cursor_xact(\$x);
    my \$xact = \$C->{_xact};

    my \@gather = ();
    for (;;) {
        unless (\@try) {
            \$relex //= \$C->cursor_fate('$PKG', '$altname', \$retree);
            \@try = \$relex->(\$C) or last;
        }
        \$try = shift(\@try) // next;

        if (ref \$try) {
            (\$C->{'_fate'}, \$tag, \$try) = \@\$try;	# next candidate fate
        }

        \$C->deb("$altname trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
        push \@gather, ((
@{[ ::indent(join("\n", @result),3) ]}
END

            $result .= <<'END';
        )[$try])->($C);
        last if @gather;
        last if $xact->[-2];  # committed?
    }
    @gather;
  };
  @result;
}
END
            $result;
        }
    }

    sub remove_leading_ws {
        my $self = shift;
        for my $kid (@{$$self{zyg}}) {
            $kid->remove_leading_ws();
        }
    }

    sub remember_alts {
        my $self = shift;
        $RETREE->{$self->{altname}} = $self;
        if ($$self{zyg}) {
            foreach my $kid (@{$$self{zyg}}) {
                $kid->remember_alts(@_);
            }
        }
    }
}

{ package RE_var; use base "REbase";
    sub walk {
        my $self = shift;
        my $var = $$self{var};
        $PURE = 0;
        if ($var =~ /^\$/) {
            if ($var =~ /^\$(\d+)$/) {
                $self->bind("\$C->_BACKREFp$REV($1)");
            }
            elsif ($var =~ /^\$<(.*)>$/) {
                $self->bind("\$C->_BACKREFn$REV('$1')");
            }
            else {
                $self->bind("\$C->_EXACT$REV($var)");
            }
        }
        elsif ($var =~ /^\@/) {
            $self->bind("\$C->_ARRAY$REV($var)");
        }
        elsif ($var =~ /^\%/) {
            $self->bind("\$C->_HASH$REV($var)");
        }
    }
}


MAIN();

## vim: expandtab sw=4
