hexfp: printf %a for negative zero.

[perl5.git] / t / op / sprintf2.t

diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 3e32746..6aa994c 100644 (file)
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -12,6 +12,8 @@ BEGIN {
 eval { my $q = pack "q", 0 };
 my $Q = $@ eq '';
 
+my $doubledouble;
+
 # %a and %A depend on the floating point config
 # This totally doesn't test non-IEEE-754 float formats.
 my @hexfloat;
@@ -189,6 +191,7 @@ if ($Config{nvsize} == 8 &&
     (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ ||  # LE
      pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/)    # BE
     ) {
+    $doubledouble = 1;
     @hexfloat = (
        [ '%a', '0',       '0x0p+0' ],
        [ '%a', '1',       '0x1p+0' ],
@@ -240,7 +243,7 @@ if ($Config{nvsize} == 8 &&
     print "# no hexfloat tests\n";
 }
 
-plan tests => 1406 + ($Q ? 0 : 12) + @hexfloat;
+plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 8;
 
 use strict;
 use Config;
@@ -557,19 +560,45 @@ for my $width (1,2,3,4,5,6,7) {
 }
 
 # Overload count
-package o { use overload '""', sub { ++our $count; $_[0][0]; } }
-my $o = bless ["\x{100}"], o::;
+package o {
+    use overload
+        '""', sub { ++our $count; $_[0][0]; },
+        '0+', sub { ++our $numcount; $_[0][1]; }
+}
+my $o = bless ["\x{100}",42], o::;
 () = sprintf "%1s", $o;
 is $o::count, '1', 'sprinf %1s overload count';
 $o::count = 0;
 () = sprintf "%.1s", $o;
 is $o::count, '1', 'sprinf %.1s overload count';
+$o::count = 0;
+() = sprintf "%d", $o;
+is $o::count,    0, 'sprintf %d string overload count is 0';
+is $o::numcount, 1, 'sprintf %d number overload count is 1';
+
+my $ppc64_linux = $Config{archname} =~ /^ppc64-linux/;
+my $irix_ld     = $Config{archname} =~ /^IP\d+-irix-ld$/;
 
 for my $t (@hexfloat) {
     my ($format, $arg, $expected) = @$t;
     $arg = eval $arg;
     my $result = sprintf($format, $arg);
     my $ok = $result eq $expected;
+    if ($doubledouble && $ppc64_linux && $arg =~ /^2.71828/) {
+        # ppc64-linux has buggy exp(1).
+        local $::TODO = "$Config{archname} exp(1)";
+        ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
+        next;
+    }
+    if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) {
+        # irix has buggy sqrt(2),
+        # last hexdigit one bit error:
+        # gets  '0x1.6a09e667f3bcc908b2fb1366eacp+0'
+        # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0'
+        local $::TODO = "$Config{archname} sqrt(2)";
+        ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
+        next;
+    }
     unless ($ok) {
         # It seems that there can be difference in the last bits:
         # [perl #122578]
@@ -629,3 +658,29 @@ for my $t (@hexfloat) {
     }
     ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
 }
+
+# double-double long double %a special testing.
+SKIP: {
+    skip("$^O doublekind=$Config{doublekind}", 6)
+        unless ($Config{doublekind} == 4 && $^O eq 'linux');
+    # [rt.perl.org 125633]
+    like(sprintf("%La\n", (2**1020) + (2**-1072)),
+         qr/^0x1.0{522}1p\+1020$/);
+    like(sprintf("%La\n", (2**1021) + (2**-1072)),
+         qr/^0x1.0{523}8p\+1021$/);
+    like(sprintf("%La\n", (2**1022) + (2**-1072)),
+         qr/^0x1.0{523}4p\+1022$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1072)),
+         qr/^0x1.0{523}2p\+1023$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1073)),
+         qr/^0x1.0{523}1p\+1023$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1074)),
+         qr/^0x1.0{524}8p\+1023$/);
+}
+
+SKIP: {
+    skip("negative zero not available\n", 2)
+        unless sprintf('%+f', -0.0) =~ /^-0/;
+    is(sprintf("%a", -0.0), "-0x0p+0", "negative zero");
+    is(sprintf("%+a", -0.0), "-0x0p+0", "negative zero");
+}