Skip to content
This repository
Browse code

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
  • Loading branch information...
commit 4aaf1cf5c3473922cac232dfa925b0fe86bba7b4 1 parent e4efd86
Reini Urban authored
53  lib/Parrot/Test.pm
@@ -272,6 +272,14 @@ Generate functions that are only used by a couple of Parrot::Test::<lang>
272 272
 modules. This implementation is experimental and currently only works for
273 273
 languages/pipp.
274 274
 
  275
+=item C<pbc_output_numcmp($code, $expected, precision, $description, %options)>
  276
+
  277
+Runs the Parrot bytecode and passes the test if the output matches the
  278
+expected result within the given numeric precision of digits, I<and>
  279
+if Parrot exits with a non-zero exit code.
  280
+
  281
+The output lines are compared line by line to the expected string.
  282
+
275 283
 =back
276 284
 
277 285
 =cut
@@ -553,9 +561,9 @@ verified to match the single or multiple regular expressions given.
553 561
 sub pbc_postprocess_output_like {
554 562
     my ( $postprocess, $file, $ext, $check, $diag ) = @_;
555 563
     my $testno   = $builder->current_test() + 1;
556  
-    my $codefn   = "$0.$testno.$ext";
557  
-    my $pbcfn    = "$0.$testno.pbc";
558  
-    my $stdoutfn = "$0.$testno.stdout";
  564
+    my $codefn   = "${0}_$testno.$ext";
  565
+    my $pbcfn    = "${0}_$testno.pbc";
  566
+    my $stdoutfn = "${0}_$testno.stdout";
559 567
     my $f        = IO::File->new(">$codefn");
560 568
     my $parrot   = File::Spec->catfile( ".", $PConfig{test_prog} );
561 569
     $f->print($file);
@@ -786,6 +794,7 @@ sub _generate_test_functions {
786 794
         $_ . '_error_output_isnt'   => 'isnt_eq',
787 795
         $_ . '_output_like'         => 'like',
788 796
         $_ . '_error_output_like'   => 'like',
  797
+        $_ . '_output_numcmp'       => 'numcmp',
789 798
         $_ . '_output_unlike'       => 'unlike',
790 799
         $_ . '_error_output_unlike' => 'unlike',
791 800
     } qw( pasm pbc pir );
@@ -814,7 +823,7 @@ sub _generate_test_functions {
814 823
 
815 824
             no strict 'refs';
816 825
             local *{ $call_pkg . '::TODO' } = ## no critic Variables::ProhibitConditionalDeclarations
817  
-                \$extra{todo}
  826
+                                              \$extra{todo}
818 827
                 if defined $extra{todo};
819 828
 
820 829
             if ( $func =~ /_exit_code_is$/ ) {
@@ -839,7 +848,9 @@ sub _generate_test_functions {
839 848
                         . "Received:\n$real_output\nExpected:\n$expected\n" );
840 849
                 return 0;
841 850
             }
842  
-            my $pass = $builder->$meth( $real_output, $expected, $desc );
  851
+            my $pass = $builder->$meth( $real_output, $expected,
  852
+					($meth =~ /numcmp$/ ? $extra{precision} : (),
  853
+					 $desc) );
843 854
             $builder->diag("'$cmd' failed with exit code $exit_code")
844 855
                 if not $pass and $exit_code;
845 856
             return $pass;
@@ -1149,6 +1160,38 @@ sub _unlink_or_retain {
1149 1160
     return $deleted;
1150 1161
 }
1151 1162
 
  1163
+package Test::Builder;
  1164
+
  1165
+sub _normalize {
  1166
+    my ($num, $prec) = @_;
  1167
+    $prec--; # because the leading digit does also count
  1168
+    my $s = sprintf("%.${prec}e", $num);
  1169
+    if ($s =~ /^(.*)(\d)e(.+)/) { # strip overlong numbers
  1170
+	# and round last digit
  1171
+	$s = $1.($2 <5 ? '0e' : '5e').$3;
  1172
+    } else {
  1173
+	$s = substr($s, 0, $prec-1).round(substr($s, $prec, 1));
  1174
+    }
  1175
+    return 0.0 + $s;
  1176
+}
  1177
+
  1178
+sub numcmp {
  1179
+    my ($builder, $out, $expected, $precision, $desc) = @_;
  1180
+    if ($out eq $expected) {
  1181
+	return $builder->ok($desc);
  1182
+    }
  1183
+    my $epsilon = 1.0 / $precision;
  1184
+    my @out = split(/\r?\n/, $out);
  1185
+    my @exp = split(/\r?\n/, $expected);
  1186
+    for my $i (0 .. $#out) {
  1187
+	next if $out[$i] == $exp[$i];
  1188
+	return $builder->is_num($out[$i], $exp[$i], $desc)
  1189
+	  if abs(_normalize($out[$i], $precision)
  1190
+	       - _normalize($exp[$i], $precision)) > $epsilon;
  1191
+    }
  1192
+    $builder->ok($desc);
  1193
+}
  1194
+
1152 1195
 package DB;
1153 1196
 
1154 1197
 sub uplevel_args {
2  src/packfile/pf_items.c
@@ -1063,7 +1063,7 @@ cvt_num8_num4(ARGOUT(unsigned char *dest), ARGIN(const unsigned char *src))
1063 1063
     float f;
1064 1064
     double d;
1065 1065
     memcpy(&d, src, 8);
1066  
-    f = (float)d; /* TODO: test compiler cast */
  1066
+    f = (float)d;
1067 1067
     memcpy(dest, &f, 4);
1068 1068
 }
1069 1069
 
9  t/native_pbc/Test.pm
@@ -60,6 +60,7 @@ sub test_native_pbc {
60 60
     my $desc = shift;
61 61
     my $skip = shift;
62 62
     my $todo = shift;
  63
+    my $precision = shift if @_;
63 64
     my $file = "t/native_pbc/${type}_${id}.pbc";
64 65
     if ($type eq 'number') {
65 66
         $arch = num_arch();
@@ -106,8 +107,9 @@ sub test_native_pbc {
106 107
                        . "Please report success."
107 108
         }
108 109
 	if ($type eq 'number') {
109  
-	    Parrot::Test::pbc_output_like( $file, $expected, "$cvt $desc",
110  
-					   todo => "$todo_msg" );
  110
+	    Parrot::Test::pbc_output_numcmp( $file, $expected, "$cvt $desc",
  111
+					     (todo => "$todo_msg",
  112
+					      precision => $precision) );
111 113
 	} else {
112 114
 	    Parrot::Test::pbc_output_is( $file, $expected, "$cvt $desc",
113 115
 					 todo => "$todo_msg" );
@@ -117,7 +119,8 @@ sub test_native_pbc {
117 119
         skip $skip_msg, 1 if $bc ne $pbc_bc_version;
118 120
         skip $skip_msgv, 1 if $version ne $pbc_version;
119 121
 	if ($type eq 'number') {
120  
-	    Parrot::Test::pbc_output_like( $file, $expected, "$cvt $desc" );
  122
+	    Parrot::Test::pbc_output_numcmp( $file, $expected, "$cvt $desc",
  123
+					     precision => $precision );
121 124
 	} else {
122 125
 	    Parrot::Test::pbc_output_is( $file, $expected, "$cvt $desc" );
123 126
 	}
20  t/native_pbc/number.t
@@ -70,7 +70,7 @@ my $output = << 'END_OUTPUT';
70 70
 16384
71 71
 -65536
72 72
 -262144
73  
--10.48576\d*
  73
+-10.48576
74 74
 4194304
75 75
 16777216
76 76
 67108864
@@ -81,7 +81,7 @@ my $output = << 'END_OUTPUT';
81 81
 68719476736
82 82
 274877906944
83 83
 1099511627776
84  
-4.39804651110\d*
  84
+4.398046511104
85 85
 17592186044416
86 86
 70368744177664
87 87
 281474976710656
@@ -98,8 +98,8 @@ sub min_precision {
98 98
     my $myprec = shift;
99 99
     my ($theirtype) = $id =~ m/^\d_(\d.*)_/;
100 100
     # See various LDBL_DIG
101  
-    my $prec = {4 => 7, 8 => 15, 10 => 18, '16ppc' => 31, 16 => 41};
102  
-    my $theirprec = $prec->{$theirtype} // 7;
  101
+    my $prec = {4 => 6, 8 => 15, 10 => 16, '16ppc' => 31, 16 => 41};
  102
+    my $theirprec = $prec->{$theirtype}; $theirprec = 7 unless $theirprec;
103 103
     return $myprec < $theirprec ? $myprec : $theirprec;
104 104
 }
105 105
 
@@ -109,20 +109,12 @@ sub test_pbc_number {
109 109
     my $id   = shift;
110 110
     my $desc = shift;
111 111
 
112  
-    # required precision: 7 for float, 15 for double, ...
  112
+    # required precision: 6 for float, 15 for double, ...
113 113
     my $out = $output;
114 114
     my $minprec = min_precision($id, $myprec);
115 115
     # [GH #xxx] Looks like we cannot guarantee more then 13 digits
116 116
     $minprec = 13 if $minprec > 13 and $id ne $arch;
117  
-    $minprec -= 2;
118  
-    my $prec1 = $minprec - 2; # 4.398046511104 => 4.398046\d*
119  
-    #my $prec2 = $minprec - 3; # -10.48576 => -10.48576\d*
120  
-    #$out =~ s/^(-?\d\d\.\d{$prec2,})\d*/$1\\d*/mg;
121  
-    $out =~ s/^(-?\d\.\d{$prec1,})\d+$/$1\\d*/mg;
122  
-    $out =~ s/^(-?\d{$minprec,})\d+$/$1\\d*/mg;
123  
-    my $qr = qr/$out/;
124  
-
125  
-    test_native_pbc($id, "number", $qr, $desc, $skip, $todo);
  117
+    test_native_pbc($id, "number", $out, $desc, $skip, $todo, $minprec);
126 118
 }
127 119
 
128 120
 # execute t/native_pbc/number_*.pbc

0 notes on commit 4aaf1cf

Please sign in to comment.
Something went wrong with that request. Please try again.