cvsuser 02/07/18 00:28:19
Modified: languages/perl6/P6C TestCompiler.pm
Log:
Better error diagnostics.
Revision Changes Path
1.3 +29 -7 parrot/languages/perl6/P6C/TestCompiler.pm
Index: TestCompiler.pm
===================================================================
RCS file: /cvs/public/parrot/languages/perl6/P6C/TestCompiler.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- TestCompiler.pm 18 Jul 2002 02:44:31 -0000 1.2
+++ TestCompiler.pm 18 Jul 2002 07:28:19 -0000 1.3
@@ -2,6 +2,23 @@
my $PARROT = '../..';
my $PERL = $ENV{PERL} || 'perl';
+my $ERR = 'a.err';
+my $testno = 0;
+my $code;
+
+sub dumperr {
+ open IN, $ERR;
+ print STDERR <IN>;
+ close IN;
+ open O, ">test-$testno.p6";
+ print O $code;
+ close O;
+ for my $ext (qw(pasm pbc imc err)) {
+ rename "a.$ext", "test-$testno.$ext";
+ }
+ print STDERR "See test-$testno.{p6,imc,pasm,pbc} for output,",
+ "and test-$testno.err for errors\n";
+}
sub import {
my $pkg = caller;
@@ -24,21 +41,26 @@
}
sub output_is {
- my ($code, $out, $desc) = @_;
+ $code = shift;
+ ++$testno;
+ my ($out, $desc) = @_;
unless ($desc) {
(undef, my $file, my $line) = caller;
$desc = "($file line $line)";
}
- open(O, "| perl prd-perl6.pl --batch --imc > a.imc 2>/dev/null") or die $!;
+ open(O, "| perl prd-perl6.pl --batch --imc > a.imc 2>$ERR") or die $!;
print O $code;
unless (close O) {
- ok(0, "$desc: parse: $!");
+ ok(0, "$desc: compile error: $!");
+ dumperr;
+ return;
+ }
+ unless(mysystem("$PARROT/languages/imcc/imcc a.imc a.pasm 2>$ERR", $desc)
+ && mysystem("$PERL $PARROT/assemble.pl a.pasm > a.pbc 2>$ERR",$desc)
+ && mysystem("$PARROT/parrot a.pbc > a.output 2>$ERR", $desc)) {
+ dumperr;
return;
}
- (mysystem("$PARROT/languages/imcc/imcc a.imc a.pasm 2>/dev/null", $desc)
- && mysystem("$PERL $PARROT/assemble.pl a.pasm > a.pbc", $desc)
- && mysystem("$PARROT/parrot a.pbc > a.output", $desc))
- or return 0;
open(I, 'a.output');
my $result = join '', <I>;
ok($out eq $result, $desc);
