# common code for all compiler tests - see t/*compiler-*.t

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use Language::INTERCAL::GenericIO '1.-94.-2', qw($devnull);
use Language::INTERCAL::Sick '1.-94.-2';
use Language::INTERCAL::Rcfile '1.-94.-2';
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);

my $rc = new Language::INTERCAL::Rcfile;
my $cobj = new Language::INTERCAL::Sick($rc);

sub runtest {
    my ($language, $give_up, $tests) = @_;
    my $maxtest = 1 + 3 * @$tests;
    print "1..$maxtest\n";
    my $testnum = 1;
    my $i_data = '';
    my $i_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$i_data);
    my $o_data = '';
    my $o_fh = Language::INTERCAL::GenericIO->new('STRING', 'w', \$o_data);
    eval {
	$cobj->reset();
	$cobj->setoption('default_charset', 'ASCII');
	$cobj->setoption('default_backend', 'Run');
	$cobj->clearoption('preload');
	if (ref $language) {
	    $cobj->setoption('preload', $_) for @$language;
	} else {
	    $cobj->setoption('preload', $language);
	}
	$cobj->setoption('trace', 0);
	$cobj->source('null.iacc');
	$cobj->load_objects();
	$obj = $cobj->get_object('null.iacc')
	    or die "Internal error: no compiler object\n";
	$obj->object->setbug(0, 0);
#$obj->setreg('%TM', 1); 0 and
	$obj->setreg('@TRFH', $devnull);
	$obj->setreg('@OWFH', $i_fh);
	$obj->setreg('@OSFH', $o_fh);
	$obj->setreg('@ORFH', $o_fh);
    };
    if ($@) {
	# if we can't even load the compiler...
	print STDERR "FAILED $language: $@";
	print "not ok ", $testnum++, "\n" while $testnum <= $maxtest;
	return;
    }
    print "ok ", $testnum++, "\n";
    for my $T (@$tests) {
	my ($name, $in, $out, $splat, $source) = @$T;
	$source .= "\n$give_up\n";
	eval { $obj->compile($source) };
	if ($@) {
	    print STDERR "Failed: compiling $name\n";
	    print "not ok ", $testnum++, "\n" for (1..3);
	    next;
	}
	print "ok ", $testnum++, "\n";
	$i_data = $in;
	$i_fh->reset;
	$o_data = '';
	$o_fh->reset;
	eval { $obj->start()->run()->stop() };
	if ($@) {
	    print STDERR "Failed: running $name\n";
	    print "not ok ", $testnum++, "\n" for (2..3);
	    next;
	}
	my $os = $obj->splat;
	if (defined $os) {
	    print defined $splat && $os == $splat ? "" : "not ", "ok ", $testnum++, "\n";
	    print STDERR "Failed $name (*$os)\n" unless defined $splat && $os == $splat;
	} else {
	    print defined $splat ? "not " : "", "ok ", $testnum++, "\n";
	    print STDERR "Failed $name (no splat)\n" if defined $splat;
	}
	my $ok = ref $out ? (grep { $_ eq $o_data } @$out) : ($o_data eq $out);
	if ($ok) {
	    print "ok ", $testnum++, "\n";
	} else {
	    my $O = $o_data; $O =~ s/\n/\\n/g;
	    print STDERR "Failed $name (invalid output $O)\n";
	    print "not ok ", $testnum++, "\n";
	}
    }
}

1;