package P6C::IMCC::ExtRegex::Rewrite;
use base 'Regex::Rewrite';
require P6C::IMCC;
use strict;

=head1 NAME

P6C::IMCC::ExtRegex::CodeGen

=head1 SUMMARY

Subclass of C<Regex::Rewrite> (found in languages/regex/lib) for
generating code that requires Perl6-specific functionality.

C<Regex::Rewrite> calls methods named C<rewrite_X> for every tree opcode
C<X> generated by the parser or adapter. (see
L<P6C::IMCC::ExtRegex::Adapter>). Each rewrite method must return an
array of list ops implementing the "operation" C<X>.

=head1 FUNCTIONS

=over 4

=item lop

Shortcut for creating a new list op.

=cut

sub lop {
    Regex::Ops::List->op(@_);
}

=item otherop

Create a passthru op that inserts a PIR expression directly into the
output stream.

=cut

sub otherop {
    lop('other' => [ @_ ]);
}

sub where {
    my ($package, $filename, $line) = caller;
    return "[$filename:$line]";
}

=item new_local

Create a new local variable. Mainly just dispatches to
P6C::IMCC::add_localvar, but also make the variable unique. Uniquer.
Um... something.

The intent is to create a variable that is local to the
currently-being-rewritten rule match. The reason why it can't just
bounce over to the P6C routine is because we could generate multiple
rule matches within one subroutine, so we need to ensure that their
local variables do not collide.

=cut

my $XXX;
sub new_local {
    my ($self, $name, $type) = @_;
    $type ||= "int";

    # Ugh. One IMCC sub may contain multiple locals of the same name,
    # and P6C::IMCC doesn't auto-rename for you. So this hack will do
    # global renaming.
#    if (++$self->{_locals}{$name} != 1) {
#        $name .= "_$self->{_locals}{$name}_";
#    }
    $name .= "_".++$XXX."_";

    return P6C::IMCC::add_localvar($name, $type);
}

=item rewrite_string

Match a Perl6 string variable. $atom is a Node corresponding to the
string var to match (it will have $atom->var called on it.)

=cut

sub rewrite_string {
    my ($self, $op, $atom, $ctx, $lastback) = @_;

    my $string = $self->new_local("string", "str");
    my $strlen = $self->new_rxlocal($op, "strlen", "int");
    my $search_end = $self->new_local("search_end", "int");
    my $substr = $self->new_local("substr", "str");

    my $back = $self->genlabel('string_back');
    my $next = $self->genlabel('string_next');

    my @ops = (         lop('string' => [ $string, $atom ]),
                        lop('length' => [ $strlen, $string ]),
                        lop('add' => [ $search_end, $strlen, '<rx_pos>' ]),
                        lop('gt' => [ $search_end, '<rx_len>', $lastback ]),
                        lop('substr' => [ $substr, '<rx_input>', '<rx_pos>', $strlen ]),
                        lop('ne' => [ $substr, $string, $lastback ]),
                        lop('add' => [ '<rx_pos>', $strlen ]),
                        lop('goto' => [ $next ]),
               $back => $self->op_restore_rxlocals($op),
                        $self->dbprint("backtracking over %<$strlen>-char string (var is $strlen)\n"),
                        lop('sub' => [ '<rx_pos>', $strlen ]),
                        lop('goto' => [ $lastback ]),
               $next => $self->op_save_rxlocals($op),
              );
    return ($back, @ops);
}

=item rewrite_array_literal

Match a Perl6 array $array by doing an exact match on each element of
the array. Uses rewrite_dynamic_alternate, defined in the superclass
C<Regex::Rewrite>.

=cut

sub rewrite_array_literal {
  my ($self, $op, $array, $ctx, $lastback) = @_;
  $array = ref($array) ? $array->val : $array;

  # Return ops to compute the number of elements to try to match,
  # along with the variable containing the result
  my $sizer = sub {
      my ($self, $op) = @_;
      my $N = $self->new_rxlocal($op, 'arraysize', 'int');
      return ($N,
              lop('array_length', [ $N, $array ]));
  };

  # Return ops to check whether the given element was matched.
  my $match_elt = sub {
    my ($self, $op, $index, $lastback) = @_;
    my $tmp = $self->new_local('element', 'str');
    my $str_ctx = new P6C::Context type => 'str';
    my ($back, @ops) = $self->rewrite_string($op, $tmp, $ctx, $lastback);
    return ($back,
	    lop('array_elt', [ $tmp, $array, $index, $str_ctx ]),
            $self->dbprint("matching '%<$tmp>'...\n"),
            @ops);
  };

  return $self->rewrite_dynamic_alternate($op, $sizer, $match_elt, $lastback);
}

=item rewrite_call

Call a subrule. $rule is a C<P6C::rx_call>.

=cut

sub rewrite_call {
    my ($self, $op, $call, $lastback) = @_;
    my @ops;
    my $matched = $self->new_local("rule_matched", "int");
#    my $call = $self->genlabel("call_rule");
    my $after = $self->genlabel("after_call");
    my $back = $self->genlabel("call_back");
    my $next = $self->genlabel("call_next");

    my $arguments0 = [ ];
    push @$arguments0, [ "mode", "int", 0 ];
    push @$arguments0, [ "stack", "PerlArray", "<rx_stack>" ];
    push @$arguments0, [ "input", "str", "<rx_input>" ];
    push @$arguments0, [ "pos", "int", "<rx_pos>" ];

    my $arguments1 = [ @$arguments0 ];
    $arguments1->[0] = [ "mode", "int", 1 ];

    my $retvals = [ [ "int", $matched ], [ "int", "<rx_pos>" ] ];

    push @ops, (          lop('call_rule' => [ $call, $arguments0, $retvals ]),
                $after => $self->dbprint("rule succeeded? %<$matched>\n"),
                          lop('eq' => [ $matched, 1, $next ]),
                          lop('goto' => [ $lastback ]),
                 $back => lop('call_rule' => [ $call, $arguments1, $retvals ]),
                          lop('goto' => [ $after ]),
                 $next =>
               );

    return ($back, @ops);
}

1;

=back

=cut
