test with precision (numcmp)

All tests pass now, just __float128 has problems printing certain numbers properly. E.g. __float128 is probed for %.17Lg fmt, which prints 3.8 as 3.7999999999999998
parrot · Sep 13, 2012 · 4aaf1cf · 4aaf1cf
1 parent e4efd86
commit 4aaf1cf
Show file tree

Hide file tree

Showing 4 changed files with 61 additions and 23 deletions.
diff --git a/lib/Parrot/Test.pm b/lib/Parrot/Test.pm
@@ -272,6 +272,14 @@ Generate functions that are only used by a couple of Parrot::Test::<lang>
 modules. This implementation is experimental and currently only works for
 languages/pipp.
 
+=item C<pbc_output_numcmp($code, $expected, precision, $description, %options)>
+
+Runs the Parrot bytecode and passes the test if the output matches the
+expected result within the given numeric precision of digits, I<and>
+if Parrot exits with a non-zero exit code.
+
+The output lines are compared line by line to the expected string.
+
 =back
 
 =cut
@@ -553,9 +561,9 @@ verified to match the single or multiple regular expressions given.
 sub pbc_postprocess_output_like {
     my ( $postprocess, $file, $ext, $check, $diag ) = @_;
     my $testno   = $builder->current_test() + 1;
-    my $codefn   = "$0.$testno.$ext";
-    my $pbcfn    = "$0.$testno.pbc";
-    my $stdoutfn = "$0.$testno.stdout";
+    my $codefn   = "${0}_$testno.$ext";
+    my $pbcfn    = "${0}_$testno.pbc";
+    my $stdoutfn = "${0}_$testno.stdout";
     my $f        = IO::File->new(">$codefn");
     my $parrot   = File::Spec->catfile( ".", $PConfig{test_prog} );
     $f->print($file);
@@ -786,6 +794,7 @@ sub _generate_test_functions {
         $_ . '_error_output_isnt'   => 'isnt_eq',
         $_ . '_output_like'         => 'like',
         $_ . '_error_output_like'   => 'like',
+        $_ . '_output_numcmp'       => 'numcmp',
         $_ . '_output_unlike'       => 'unlike',
         $_ . '_error_output_unlike' => 'unlike',
     } qw( pasm pbc pir );
@@ -814,7 +823,7 @@ sub _generate_test_functions {
 
             no strict 'refs';
             local *{ $call_pkg . '::TODO' } = ## no critic Variables::ProhibitConditionalDeclarations
-                \$extra{todo}
+                                              \$extra{todo}
                 if defined $extra{todo};
 
             if ( $func =~ /_exit_code_is$/ ) {
@@ -839,7 +848,9 @@ sub _generate_test_functions {
                         . "Received:\n$real_output\nExpected:\n$expected\n" );
                 return 0;
             }
-            my $pass = $builder->$meth( $real_output, $expected, $desc );
+            my $pass = $builder->$meth( $real_output, $expected,
+					($meth =~ /numcmp$/ ? $extra{precision} : (),
+					 $desc) );
             $builder->diag("'$cmd' failed with exit code $exit_code")
                 if not $pass and $exit_code;
             return $pass;
@@ -1149,6 +1160,38 @@ sub _unlink_or_retain {
     return $deleted;
 }
 
+package Test::Builder;
+
+sub _normalize {
+    my ($num, $prec) = @_;
+    $prec--; # because the leading digit does also count
+    my $s = sprintf("%.${prec}e", $num);
+    if ($s =~ /^(.*)(\d)e(.+)/) { # strip overlong numbers
+	# and round last digit
+	$s = $1.($2 <5 ? '0e' : '5e').$3;
+    } else {
+	$s = substr($s, 0, $prec-1).round(substr($s, $prec, 1));
+    }
+    return 0.0 + $s;
+}
+
+sub numcmp {
+    my ($builder, $out, $expected, $precision, $desc) = @_;
+    if ($out eq $expected) {
+	return $builder->ok($desc);
+    }
+    my $epsilon = 1.0 / $precision;
+    my @out = split(/\r?\n/, $out);
+    my @exp = split(/\r?\n/, $expected);
+    for my $i (0 .. $#out) {
+	next if $out[$i] == $exp[$i];
+	return $builder->is_num($out[$i], $exp[$i], $desc)
+	  if abs(_normalize($out[$i], $precision)
+	       - _normalize($exp[$i], $precision)) > $epsilon;
+    }
+    $builder->ok($desc);
+}
+
 package DB;
 
 sub uplevel_args {

diff --git a/src/packfile/pf_items.c b/src/packfile/pf_items.c
@@ -1063,7 +1063,7 @@ cvt_num8_num4(ARGOUT(unsigned char *dest), ARGIN(const unsigned char *src))
     float f;
     double d;
     memcpy(&d, src, 8);
-    f = (float)d; /* TODO: test compiler cast */
+    f = (float)d;
     memcpy(dest, &f, 4);
 }
 

diff --git a/t/native_pbc/Test.pm b/t/native_pbc/Test.pm
@@ -60,6 +60,7 @@ sub test_native_pbc {
     my $desc = shift;
     my $skip = shift;
     my $todo = shift;
+    my $precision = shift if @_;
     my $file = "t/native_pbc/${type}_${id}.pbc";
     if ($type eq 'number') {
         $arch = num_arch();
@@ -106,8 +107,9 @@ sub test_native_pbc {
                        . "Please report success."
         }
 	if ($type eq 'number') {
-	    Parrot::Test::pbc_output_like( $file, $expected, "$cvt $desc",
-					   todo => "$todo_msg" );
+	    Parrot::Test::pbc_output_numcmp( $file, $expected, "$cvt $desc",
+					     (todo => "$todo_msg",
+					      precision => $precision) );
 	} else {
 	    Parrot::Test::pbc_output_is( $file, $expected, "$cvt $desc",
 					 todo => "$todo_msg" );
@@ -117,7 +119,8 @@ sub test_native_pbc {
         skip $skip_msg, 1 if $bc ne $pbc_bc_version;
         skip $skip_msgv, 1 if $version ne $pbc_version;
 	if ($type eq 'number') {
-	    Parrot::Test::pbc_output_like( $file, $expected, "$cvt $desc" );
+	    Parrot::Test::pbc_output_numcmp( $file, $expected, "$cvt $desc",
+					     precision => $precision );
 	} else {
 	    Parrot::Test::pbc_output_is( $file, $expected, "$cvt $desc" );
 	}

diff --git a/t/native_pbc/number.t b/t/native_pbc/number.t
@@ -70,7 +70,7 @@ my $output = << 'END_OUTPUT';
 16384
 -65536
 -262144
--10.48576\d*
+-10.48576
 4194304
 16777216
 67108864
@@ -81,7 +81,7 @@ my $output = << 'END_OUTPUT';
 68719476736
 274877906944
 1099511627776
-4.39804651110\d*
+4.398046511104
 17592186044416
 70368744177664
 281474976710656
@@ -98,8 +98,8 @@ sub min_precision {
     my $myprec = shift;
     my ($theirtype) = $id =~ m/^\d_(\d.*)_/;
     # See various LDBL_DIG
-    my $prec = {4 => 7, 8 => 15, 10 => 18, '16ppc' => 31, 16 => 41};
-    my $theirprec = $prec->{$theirtype} // 7;
+    my $prec = {4 => 6, 8 => 15, 10 => 16, '16ppc' => 31, 16 => 41};
+    my $theirprec = $prec->{$theirtype}; $theirprec = 7 unless $theirprec;
     return $myprec < $theirprec ? $myprec : $theirprec;
 }
 
@@ -109,20 +109,12 @@ sub test_pbc_number {
     my $id   = shift;
     my $desc = shift;
 
-    # required precision: 7 for float, 15 for double, ...
+    # required precision: 6 for float, 15 for double, ...
     my $out = $output;
     my $minprec = min_precision($id, $myprec);
     # [GH #xxx] Looks like we cannot guarantee more then 13 digits
     $minprec = 13 if $minprec > 13 and $id ne $arch;
-    $minprec -= 2;
-    my $prec1 = $minprec - 2; # 4.398046511104 => 4.398046\d*
-    #my $prec2 = $minprec - 3; # -10.48576 => -10.48576\d*
-    #$out =~ s/^(-?\d\d\.\d{$prec2,})\d*/$1\\d*/mg;
-    $out =~ s/^(-?\d\.\d{$prec1,})\d+$/$1\\d*/mg;
-    $out =~ s/^(-?\d{$minprec,})\d+$/$1\\d*/mg;
-    my $qr = qr/$out/;
-
-    test_native_pbc($id, "number", $qr, $desc, $skip, $todo);
+    test_native_pbc($id, "number", $out, $desc, $skip, $todo, $minprec);
 }
 
 # execute t/native_pbc/number_*.pbc