#!/usr/bin/perl -w

sub usage {
    my $status = shift || 1;
    print <<"END";
Usage: $0 [-c|--compile] <filename>

  Test files must contain a single regular expression on the first
  line. Next there should be any number of pairs of INPUT and OUTPUT
  sections, where an INPUT: section begins with the string 'INPUT:' on
  a line by itself, followed by some data and a newline. (The newline
  is not regarded as part of the data, so add an extra one if you want
  the input to end with a newline.) The OUTPUT: section is similar.

  Example:

(a*a|(aaa))a
INPUT:
xxxxxxxxaaabb
OUTPUT:
Match found
0: 8..10
1: 8..9
INPUT:
aaaaaaaaaaaa
OUTPUT:
Match found
0: 0..11
INPUT:
xyz
OUTPUT:
Match failed
END
  exit $status;
}

if ($ARGV[0] && $ARGV[0] =~ /^(-h|--help)$/) {
    usage(0);
}

my $compile = 0; # Compile-only flag
if ($ARGV[0] && $ARGV[0] =~ /^(-c|--compile)$/) {
    $compile = 1;
    shift;
}

my $pattern = <>;
chomp($pattern);

generate_regular($pattern);
exit(0) if $compile;

my $status = 1;

my $testCount = 1;
$_ = <>;
while (1) {
    my ($input, $output);

    last if ! defined $_;
    die "INPUT: expected" if ! /^INPUT:/;

    # Gather input, look for OUTPUT:
    $input = '';
    undef $output;
    while (<>) {
        $output = '', last if /^OUTPUT:/;
        $input .= $_;
    }
    chomp($input);
    die "EOF during INPUT: section" if ! defined($output);

    # Gather output
    while (<>) {
        last if /^INPUT:/;
        $output .= $_;
    }

    $status &&= process($input, $output, $testCount++);
}

exit ($status ? 0 : 1);

sub generate_regular_pasm {
    my ($filename, $pattern) = @_;
    open(PASM, ">$filename") or die "create $filename: $!";
    use FindBin;
    use lib "$FindBin::Bin/lib";
    use Regex;

    print PASM <<"END";
# Regular expression test
# Generated by $0
# Pattern >>$pattern<<
    get_keyed S0, P0, 1 # argv[1] (or perl5's \$ARGV[0])
    bsr REGEX
    if I0, \$matched
    print "Match failed\\n"
#    bsr DUMP
    end
\$matched:
    print "Match found\\n"
    set I0, 0
printLoop:
    set I17, I0
    bsr printGroup
    add I0, I17, 1
    eq I16, 1, printLoop
    end
printGroup:
    set I5, P0
    lt I0, I5, groupDefined
    set I16, 0
    ret
groupDefined:
    get_keyed I3, P0, I0
    get_keyed I4, P1, I0
    eq I4, -2, skipPrint
    print I0
    print ": "
    print I3
    print ".."
    add I4, I4, -1 # Off by one
    print I4
    print "\\n"
skipPrint:
    set I16, 1
    ret

DUMP:
    bsr DUMPSTRING
    bsr DUMPSTACK
    ret

DUMPSTRING:
        # Print the current position in the string
#	trace 0
        print "<"
        substr S1, S0, 0, I1
        print S1
        print "><"
        sub I21, I2, I1
        substr S1, S0, I1, I21
        print S1
        print ">\\n"
        ret

DUMPSTACK:
        # Dump the stack
        print "STACK["
        depth I10
        mul I11, I10, -1
	print I10
        print "]: "
	
DUMPLOOP:
        eq I10, 0, RETURN
	rotate_up I11
        entrytype I13, 0
	eq I13, 1, STACKINT
        restore S12
	print "'"
        print S12
	print "'"
        save S12
        branch AFTERELT
STACKINT:
	restore I12
        print I12
        save I12
AFTERELT:
        print " "
        sub I10, I10, 1
        branch DUMPLOOP

RETURN:
        print "\\n"
#	trace 1
        ret

END

    print PASM "REGEX:\n";
    my $DEBUG = 0;
    my $parser = Regex::Parse->new();
    my $opt1 = Regex::PreOptimize->new();
    my $rewrite = Regex::Rewrite::Rx->new(DEBUG => $DEBUG);
    my $opt2 = Regex::Optimize->new();
    my $cgen = Regex::CodeGen::Pasm->new(DEBUG => $DEBUG);

    my $tree = $parser->compile($pattern);
    my @code = $rewrite->run($tree);
    my @asm = $cgen->output(@code);
    @optcode = @code; # my @optcode = $opt2->optimize(@code);
    my @optasm = $cgen->output(@optcode);
    print PASM "$_\n" foreach (@optasm);

    close PASM;
}

sub generate_pbc {
    my ($pasm, $pbc) = @_;
    my $status = system("$FindBin::Bin/../../assemble.pl $pasm > $pbc");
    if (! defined($status) || $status) {
        die "assemble.pl failed: $!";
    }
}

sub generate_regular {
    my $pattern = shift;
    generate_regular_pasm("test.pasm", $pattern);
    generate_pbc("test.pasm", "test.pbc");
}

sub process {
    my ($input, $output, $testnum) = @_;
    open(TEST, "$FindBin::Bin/../../parrot test.pbc '$input' |");

    local $/;
    my $actual_output = <TEST>;
    if ($actual_output eq $output) {
        print "ok $testnum\n";
        return 1;
    } else {
        print "not ok $testnum\n";
        print " == Received ==\n$actual_output\n";
        print " == Expected ==\n$output\n";
        return 0;
    }
}
