package Regex::CodeGen::Perl5;

# Copyright (C) 2004-2006, The Perl Foundation.
# $Id: Perl5.pm 21249 2007-09-13 06:33:24Z paultcochrane $

use Regex::Ops::Tree ();    # For mark()
use base 'Regex::CodeGen';
use strict;
use warnings;

my $fail_label = Regex::Ops::Tree::mark('FAIL');

sub init_context {
    my ( $self, $ctx ) = @_;
    $ctx->{rx_match} ||= '$rx_match';
    $ctx->{rx_stack} ||= '$rx_stack';
    $ctx->{rx_tmp}   ||= '$rx_tmp';
    $ctx->{rx_pos}   ||= '$rx_pos';
    $ctx->{rx_len}   ||= '$rx_len';
    $ctx->{rx_input} ||= '$rx_input';
    $self->SUPER::init_context($ctx);
}

sub value {
    my $name = shift;
    return '$rx_pos' if $name eq '<pos>';
    return '$rx_tmp' if $name eq '<tmp>';
    return '$rx_tmp' if $name eq '<ptmp>';
    return $name;
}

sub dbgoto {
    my ( $self, $label ) = @_;
    return () unless $self->{DEBUG};
    return () unless $self->{DEBUG_SUPPORT};
    return ("goto $label");
}

sub lookup_var {
    my ( $self, $var, $ctx ) = @_;
    if ( $ctx->{$var} ) {
        return $ctx->{$var};
    }
    else {
        return '$' . $var;
    }
}

############### SIMPLE OUTPUT ##############

sub output_goto {
    my ( $self, $where ) = @_;
    return "goto " . $self->output_label_use($where) . ";";
}

sub output_terminate {
    return "";
}

sub output_advance {
    my ( $self, $distance, $failLabel ) = @_;
    $failLabel = $self->output_label_use($failLabel);
    return (
        "<rx_pos> += $distance; # pos++",
        "goto $failLabel if <rx_pos> > <rx_len>; # past end of input?",
        '<rx_match>{0}->[0] = <rx_pos>; # group 0 start := pos'
    );
}

sub output_increment {
    my ( $self, $distance, $failLabel ) = @_;
    die "invalid distance" if $distance =~ /[^\d\-]/;
    return () if $distance == 0;

    if ( $distance == 1 ) {
        return "<rx_pos>++;";
    }
    elsif ( $distance == -1 ) {
        return "<rx_pos>--;";
    }
    elsif ( $distance > 0 ) {
        return "<rx_pos> += $distance;";
    }
    elsif ( $distance < 0 ) {
        return "<rx_pos> -= $distance;";
    }
}

sub output_add {
    my ( $self, $var, $arg1, $arg2 ) = @_;
    my $realvar = value($var);
    return "$realvar = $arg1 + $arg2;" if defined($arg2);
    return "$realvar += $arg1;";
}

sub output_sub {
    my ( $self, $var, $amount ) = @_;
    $amount = 1 if !defined $amount;
    my $realvar = value($var);
    return "$realvar -= $amount;";
}

sub output_set {
    my ( $self, $reg, $value ) = @_;
    $reg = value($reg);
    return "$reg = $value;";
}

sub output_print {
    my ( $self, $what ) = @_;
    $what = value($what);
    return ("print $what;");
}

sub output_test {
    my ( $self, $test, $val1, $val2, $dest ) = @_;
    $val1 = value($val1);
    $val2 = value($val2);
    return "goto " . $self->output_label_use($dest) . " if $val1 $test $val2;";
}

sub output_eq {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '==', $val1, $val2, $dest );
}

sub output_ne {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '!=', $val1, $val2, $dest );
}

sub output_lt {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '<', $val1, $val2, $dest );
}

sub output_le {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '<=', $val1, $val2, $dest );
}

sub output_gt {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '>', $val1, $val2, $dest );
}

sub output_ge {
    my ( $self, $val1, $val2, $dest ) = @_;
    $self->output_test( '>=', $val1, $val2, $dest );
}

sub output_if {
    my ( $self, $reg, $dest ) = @_;
    $reg = value($reg);
    return "goto " . $self->output_label_use($dest) . " if $reg;";
}

sub output_unless {
    my ( $self, $reg, $dest ) = @_;
    $reg = value($reg);
    return "goto " . $self->output_label_use($dest) . " unless $reg;";
}

sub output_check {
    my ( $self, $needed, $failLabel, $lenvar ) = @_;
    $lenvar ||= "<rx_len>";
    my $fail = $self->output_label_use($failLabel);
    if ( $needed eq "1" ) {
        return "goto $fail if <rx_pos> >= $lenvar; # need $needed more chars";
    }
    elsif ( $needed eq "0" ) {
        return ();
    }
    else {
        return "goto $fail if $lenvar - <rx_pos> < $needed; # need $needed more chars";
    }
}

sub output_match {
    my ( $self, $code, $failLabel ) = @_;
    my $comment = Regex::Ops::Tree::isplain($code) ? " # match '" . chr($code) . "'" : "";
    my $fail    = $self->output_label_use($failLabel);
    my @ops     = ( "goto $fail if ord(substr(<rx_input>, <rx_pos>, 1)) != $code;" . $comment );
    if ( $self->{DEBUG} ) {
        push @ops, 'print "matched(' . chr($code) . ') at ";';
        push @ops, 'print <rx_pos>;';
        push @ops, 'print "\n";';
    }
    return @ops;
}

sub output_classmatch {
    my ( $self, $incexc, $failLabel ) = @_;

    my $passLabel = $self->{state}->genlabel("pass_charclass");
    my @ops       = ("<rx_tmp> = ord(substr(<rx_input>, <rx_pos>)); # tmp = INPUT[pos]");
    my $fail      = $self->output_label_use($failLabel);
    my $pass      = $self->output_label_use($passLabel);

    while (@$incexc) {
        my $first = shift(@$incexc);
        my $last  = shift(@$incexc);
        if ( defined($last) ) {
            push @ops, "goto $fail if <rx_tmp> < $first;"
                unless $first == 0;
            push @ops, "goto $pass if <rx_tmp> < $last;";
        }
        else {
            push @ops, "goto $pass if <rx_tmp> >= $first;";
        }
    }
    push @ops, "goto $fail;";

    push @ops, $self->output_label_def($passLabel);
    return @ops;
}

sub output_initgroup {
    my ( $self, $group ) = @_;
    return ("<rx_match>{\"$group\"} = [];");
}

sub output_setstart {
    my ( $self, $group, $value ) = @_;
    $DB::single = 1;
    $value      = value($value);
    return qq!<rx_match>{"$group"}->[0] = $value; # open group $group!;
}

sub output_setend {
    my ( $self, $group, $value, $adj ) = @_;
    $value = value($value);
    my @ops;
    if ($adj) {
        push @ops, "<rx_tmp> = $value + $adj;";
        $value = "<rx_tmp>";
    }
    push @ops, qq!<rx_match>{"$group"}->[1] = $value; # close group $group!;
    return @ops;
}

sub output_getstart {
    my ( $self, $reg, $group ) = @_;
    $reg = value($reg);
    return qq!$reg = <rx_match>{"$group"}->[0]; # get group $group start!;
}

sub output_getend {
    my ( $self, $reg, $group ) = @_;
    $reg = value($reg);
    return qq!$reg = <rx_match>{"$group"}->[1]; # get group $group end!;
}

sub output_delete {
    my ( $self, $n ) = @_;
    return qq!<rx_match>{"$n"}->[1] = undef; # delete group $n!;
}

sub output_atend {
    my ( $self, $failLabel ) = @_;
    my $fail = $self->output_label_use($failLabel);
    return (
        $self->dbprint("At end: %<rx_pos> >= %<rx_len>?\n"),
        "goto $fail if <rx_pos> < <rx_len>; # at end?"
    );
}

sub output_pushmark {
    my ($self) = @_;
    my @ops;
    if ( $self->{DEBUG} ) {
        push @ops, ( qq(print "PUSHED ) . ( @_ > 1 ? $_[1] : "mark" ) . qq(\\n";) );
    }
    push @ops, "push \@<rx_stack>, -1; # pushmark";
    return @ops;
}

sub output_pushindex {
    my ( $self, $reg ) = @_;
    $reg = value( defined($reg) ? $reg : 'pos' );
    return $self->output_pushint($reg);
}

sub output_pushint {
    my ( $self, $reg, $db_desc ) = @_;
    $reg = value($reg);

    if ( $self->{DEBUG} ) {
        my $desc = $db_desc ? " ($db_desc)" : "";
        return (
            "\$dbg_tmp = \@<rx_stack>;",
            "push \@<rx_stack>, $reg;",
            $self->dbprint("PUSHED[\$dbg_tmp] INT: \%<$reg>$desc\n"),
        );
    }
    return "push \@<rx_stack>, $reg;";
}

sub output_save {
    my ( $self, $reg ) = @_;
    $reg = value($reg);
    return ("push \@::STATESTACK, $reg;");
}

sub output_restore {
    my ( $self, $reg ) = @_;
    $reg = value($reg);
    return ("$reg = pop \@::STATESTACK;");
}

sub output_refresh {
    my ( $self, $reg ) = @_;
    $reg = value($reg);
    return ("$reg = \$::STATESTACK[-1]");
}

use vars qw($DEBUG_LABEL);

sub output_popindex {
    my $self = shift;

    my ( $reg, $fallback );
    if ( @_ == 1 ) {
        ( $reg, $fallback ) = ( 'pos', @_ );
    }
    elsif ( @_ == 2 ) {
        ( $reg, $fallback ) = @_;
    }
    elsif ( @_ == 0 ) {
        die "Must always have fallback defined!";
    }
    else {
        die "Too many arguments to popindex!";
    }

    $reg = value($reg);

    my @ops = ("<rx_tmp> = pop \@<rx_stack>; # popindex");
    if ( $self->{DEBUG} ) {
        push @ops, 'print "POPPED: <rx_tmp>\n";';
    }

    # FIXME: Still have extra copy in many cases
    my $L_fallback = $self->output_label_use($fallback);
    push @ops, "goto $L_fallback if <rx_tmp> == -1; # was a mark?";
    push @ops, "$reg = <rx_tmp>; # nope, set pos := popped index"
        unless $reg eq '$<rx_tmp>';
    return @ops;
}

sub output_peekindex {
    my $self = shift;
    my ( $reg, $fallback );
    if ( @_ == 1 ) {
        ( $reg, $fallback ) = ( 'pos', @_ );
    }
    elsif ( @_ == 2 ) {
        ( $reg, $fallback ) = @_;
    }
    elsif ( @_ == 0 ) {
        die "Must always have fallback defined!";
    }
    else {
        die "Too many arguments to popindex!";
    }

    $reg = value($reg);

    my $L_fallback = $self->output_label_use($fallback);
    return (
        "<rx_tmp> = <rx_stack>->[-1]; # peekindex",
        "goto $L_fallback if <rx_tmp> == -1; # was a mark?",
        "$reg = <rx_tmp>; # nope, set pos := popped index"
    );
}

sub output_popint {
    my ( $self, $reg, $db_desc ) = @_;
    $reg = value($reg);
    if ( $self->{DEBUG} ) {
        my $desc = $db_desc ? " ($db_desc)" : "";
        return (
            "\$dbg_tmp = \@<rx_stack>;",
            "$reg = pop \@<rx_stack>;",
            $self->dbprint("POPPED[\$dbg_tmp] INT: \%<$reg>$desc\n"),
        );
    }
    else {
        return ("$reg = pop \@<rx_stack>; # popint");
    }
}

sub output_substr {
    my ( $self, $dest, $src, $offset, $len ) = @_;
    return ("$dest = substr($src, $offset, $len);");
}

sub output_length {
    my ( $self, $dest, $string ) = @_;
    return ("$dest = length $string;");
}

sub output_arg {
    my ( $self, $name, $type, $value ) = @_;
    $value = value($value);
    return "$value, ";
}

sub output_param {
    my ( $self, $name, $type, $reg ) = @_;
    $reg = value($reg);
    return "$reg, ";
}

sub output_return {
    my ( $self, $rettype, $retval ) = @_;
    $retval = value($retval);
    return ("return $retval;");
}

sub output_declare {
    my ( $self, $var ) = @_;
    return ("my \$$var;\n");
}

sub output_rule_def {
    my ( $self, $name, $L_trymatch, $L_backup, $num_groups, $startup ) = @_;
    my @ops;

    #    if ($name ne 'default') {
    #     @ops = split(/\n/, <<"END");
    # sub _rule_$name {
    #     my <rx_mode> = shift;
    #     my (<rx_input>, <rx_pos>, <rx_stack>);
    #     my \%rx_match;
    #     if (<rx_mode>) {
    #         (<rx_input>, <rx_pos>, <rx_stack>) = \@_;
    #         \$rx_match{'!INPUT'} = <rx_input>;
    #         \$rx_match{'!GROUPS'} ||= [];
    #     } else {
    #         \%rx_match = %{ shift() };
    #         <rx_input> = <rx_match>{'!INPUT'};
    #         <rx_pos> = <rx_match>{'!POS'};
    #         <rx_stack> = <rx_match>{'!STACK'};
    #     }
    # END
    @ops = ( "sub _rule_$name {", 'my ($rx_mode, $rx_input, $rx_pos, $rx_stack) = @_;' );

    #    }

    if ( $self->{DEBUG} ) {
        push @ops, qq(print "Calling $name at \$rx_pos for ";);
        push @ops, qq(print \$rx_mode ? "MATCH" : "BACKTRACK", "\\n";);
        push @ops, qq(print "INPUT:\$rx_input\\n";);
        push @ops, qq(print "      " . (" " x \$rx_pos) . "^\\n";);
    }

    push @ops, "my \$dbg_tmp;\n" if $self->{DEBUG};

    push @ops, split( /\n/, <<'END');
my %rx_match;
$rx_match{'!INPUT'} = $rx_input;
$rx_match{'!GROUPS'} ||= [];
my $rx_len = length($rx_input);
my $rx_tmp;
END

    push @ops, $self->output( $startup, $self->{ctx} );

    push @ops,
        "if (\$rx_mode) { goto "
        . $self->output_label_use($L_trymatch)
        . "} else { goto "
        . $self->output_label_use($L_backup) . "};";

    return @ops;
}

sub output_rule_end {
    my ( $self, $name ) = @_;
    return ( "# End of rule $name", "}" );
}

sub output_rule_pass {
    my ( $self, $name ) = @_;
    return split( /\n/, <<'END');
$rx_match{'!POS'} = $rx_pos;
$rx_match{'!RESULT'} = 1;
$rx_match{'0'}->[1] = $rx_pos - 1;
$rx_match{'!STACK'} = $rx_stack;
return \%rx_match;
END
}

sub output_rule_fail {
    my ( $self, $name ) = @_;
    return split( /\n/, <<'END');
$rx_match{'!POS'} = $rx_pos;
$rx_match{'!RESULT'} = undef;
$rx_match{'0'}->[1] = undef;
$rx_match{'!STACK'} = \$rx_stack;
return \%rx_match;
END
}

sub output_call_setup {
    my ( $self, $name, $uid ) = @_;
    return "my \$$uid;";
}

sub output_call {
    my ( $self, $name, $mode, $uid ) = @_;

    #    if ($mode) {
    return split( /\n/, <<"END");
\$$uid = _rule_$name($mode, \$rx_input, \$rx_pos, \$rx_stack);
\$rx_pos = \$$uid\->{'!POS'};
END

    #     } else {
    #         return split(/\n/, <<"END");
    # \$$uid = _rule_$name($mode, \$$uid || <rx_match>{'$uid'});
    # \$rx_pos = \$$uid\->{'!POS'};
    # END
    #     }
}

sub output_call_result {
    my ( $self, $uid, $name, $fail ) = @_;
    my $fail_label = $self->output_label_use($fail);
    my @ops;
    if ( defined $name ) {
        push @ops, "\$rx_match{'$name'} = \$$uid;";
    }
    return ( @ops, "goto $fail_label if ! \$$uid\->{'!RESULT'};" );
}

sub output_code {
    my ( $self, $code ) = @_;

    # Assume, for now, that the code is Perl5 code
    my @ops = ("# START EMBEDDED CODE");

    # Set up a %MATCH variable
    push @ops, <<'END';
{
my %MATCH;
while (my ($key, $val) = each %rx_match) {
    if (UNIVERSAL::isa($val, 'ARRAY')) {
        my ($start, $end) = @$val;
        $end = $rx_pos if $key eq '0';
        if (defined($start) && defined($end) && $start != -2 && $end != -2) {
            $MATCH{$key} = substr($rx_match{'!INPUT'}, $start, $end - $start);
        }
    } else {
        # Don't deal with parse tree yet
        $MATCH{$key} = $val;
    }
}
END

    push @ops, $code;

    push @ops, <<'END';
}
# END EMBEDDED CODE
END

    return @ops;
}

1;

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: