X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5bf8b78e07edcdb636cf0f1a8c1e9e97f2ce2f53..c2ea8a88f8537d00ba25ec8feb63ef5dc085ef2b:/t/op/infnan.t

diff --git a/t/op/infnan.t b/t/op/infnan.t
index a3f94aa..e3cd7c9 100644
--- a/t/op/infnan.t
+++ b/t/op/infnan.t
@@ -20,27 +20,31 @@ BEGIN {
 
 my $PInf = "Inf"  + 0;
 my $NInf = "-Inf" + 0;
-my $NaN  = "NaN"  + 0;
+my $NaN;
+{
+    local $^W = 0; # warning-ness tested later.
+    $NaN  = "NaN" + 0;
+}
 
 my @PInf = ("Inf", "inf", "INF", "+Inf",
-            "Infinity", "INFINITE",
-            "1.#INF", "1#INF");
+            "Infinity",
+            "1.#INF", "1#INF", "1.#INF00");
 my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf;
 
 my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS",
-           "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND",
-           "NaN123", "NAN(123)", "nan%",
-           "nanonano"); # RIP, Robin Williams.
+           "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND", "1.#IND00",
+           "NAN(123)");
 
 my @printf_fmt = qw(e f g a d u o i b x p);
-my @packi_fmt = qw(a A Z b B h H c C s S l L i I n N v V j J w W p P u U);
+my @packi_fmt = qw(c C s S l L i I n N v V j J w W U);
 my @packf_fmt = qw(f d F);
+my @packs_fmt = qw(a4 A4 Z5 b20 B20 h10 H10 u);
 
 if ($Config{ivsize} == 8) {
     push @packi_fmt, qw(q Q);
 }
 
-if ($Config{uselongdouble}) {
+if ($Config{uselongdouble} && $Config{nvsize} > $Config{doublesize}) {
     push @packf_fmt, 'D';
 }
 
@@ -68,7 +72,9 @@ cmp_ok($NInf + $NInf, '==', $NInf, "-Inf - Inf is -Inf");
 cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf");
 cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf");
 
-cmp_ok($PInf * $PInf, '==', $PInf, "-Inf * +Inf is +Inf");
+cmp_ok($PInf * $PInf, '==', $PInf, "+Inf * +Inf is +Inf");
+cmp_ok($PInf * $NInf, '==', $NInf, "+Inf * -Inf is -Inf");
+cmp_ok($NInf * $PInf, '==', $NInf, "-Inf * +Inf is -Inf");
 cmp_ok($NInf * $NInf, '==', $PInf, "-Inf * -Inf is +Inf");
 
 is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf");
@@ -78,37 +84,90 @@ for my $f (@printf_fmt) {
     is(sprintf("%$f", $PInf), "Inf", "$PInf sprintf %$f is Inf");
 }
 
+is(sprintf("%+g", $PInf), "+Inf", "$PInf sprintf %+g");
+is(sprintf("%+g", $NInf), "-Inf", "$PInf sprintf %+g");
+
+is(sprintf("%4g",  $PInf), " Inf", "$PInf sprintf %4g");
+is(sprintf("%-4g", $PInf), "Inf ", "$PInf sprintf %-4g");
+
+is(sprintf("%+-5g", $PInf), "+Inf ", "$PInf sprintf %+-5g");
+is(sprintf("%-+5g", $PInf), "+Inf ", "$PInf sprintf %-+5g");
+
+is(sprintf("%-+5g", $NInf), "-Inf ", "$NInf sprintf %-+5g");
+is(sprintf("%+-5g", $NInf), "-Inf ", "$NInf sprintf %+-5g");
+
 ok(!defined eval { $a = sprintf("%c", $PInf)}, "sprintf %c +Inf undef");
 like($@, qr/Cannot printf/, "$PInf sprintf fails");
+ok(!defined eval { $a = sprintf("%c", "Inf")},
+  "stringy sprintf %c +Inf undef");
+like($@, qr/Cannot printf/, "stringy $PInf sprintf %c fails");
 
 ok(!defined eval { $a = chr($PInf) }, "chr(+Inf) undef");
 like($@, qr/Cannot chr/, "+Inf chr() fails");
+ok(!defined eval { $a = chr("Inf") }, "chr(stringy +Inf) undef");
+like($@, qr/Cannot chr/, "stringy +Inf chr() fails");
 
 ok(!defined eval { $a = sprintf("%c", $NInf)}, "sprintf %c -Inf undef");
 like($@, qr/Cannot printf/, "$NInf sprintf fails");
+ok(!defined eval { $a = sprintf("%c", "-Inf")},
+  "sprintf %c stringy -Inf undef");
+like($@, qr/Cannot printf/, "stringy $NInf sprintf %c fails");
 
 ok(!defined eval { $a = chr($NInf) }, "chr(-Inf) undef");
 like($@, qr/Cannot chr/, "-Inf chr() fails");
+ok(!defined eval { $a = chr("-Inf") }, "chr(stringy -Inf) undef");
+like($@, qr/Cannot chr/, "stringy -Inf chr() fails");
 
 for my $f (@packi_fmt) {
+    undef $a;
     ok(!defined eval { $a = pack($f, $PInf) }, "pack $f +Inf undef");
     like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
          "+Inf pack $f fails");
+    undef $a;
+    ok(!defined eval { $a = pack($f, "Inf") },
+      "pack $f stringy +Inf undef");
+    like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
+         "stringy +Inf pack $f fails");
+    undef $a;
     ok(!defined eval { $a = pack($f, $NInf) }, "pack $f -Inf undef");
     like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
          "-Inf pack $f fails");
+    undef $a;
+    ok(!defined eval { $a = pack($f, "-Inf") },
+      "pack $f stringy -Inf undef");
+    like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
+         "stringy -Inf pack $f fails");
 }
 
 for my $f (@packf_fmt) {
+    undef $a;
+    undef $b;
     ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
     eval { $b = unpack($f, $a) };
     cmp_ok($b, '==', $PInf, "pack $f +Inf equals $PInf");
 
+    undef $a;
+    undef $b;
     ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
     eval { $b = unpack($f, $a) };
     cmp_ok($b, '==', $NInf, "pack $f -Inf equals $NInf");
 }
 
+for my $f (@packs_fmt) {
+    undef $a;
+    ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
+    is($a, pack($f, "Inf"), "pack $f +Inf same as 'Inf'");
+
+    undef $a;
+    ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
+    is($a, pack($f, "-Inf"), "pack $f -Inf same as 'Inf'");
+}
+
+is eval { unpack "p", pack 'p', $PInf }, "Inf", "pack p +Inf";
+is eval { unpack "P3", pack 'P', $PInf }, "Inf", "pack P +Inf";
+is eval { unpack "p", pack 'p', $NInf }, "-Inf", "pack p -Inf";
+is eval { unpack "P4", pack 'P', $NInf }, "-Inf", "pack P -Inf";
+
 for my $i (@PInf) {
     cmp_ok($i + 0 , '==', $PInf, "$i is +Inf");
     cmp_ok($i, '>', 0, "$i is positive");
@@ -177,26 +236,41 @@ is(rand($NInf), $NInf, "rand(-Inf) is -Inf");
 # ~NaN    == NaN???
 # Or just declare insanity and die?
 
-SKIP: {
+TODO: {
+    local $::TODO;
     my $here = "$^O $Config{osvers}";
-    if ($here =~ /^hpux 10/) {
-        skip "$here: pow doesn't generate Inf", 1;
-    }
+    $::TODO = "$here: pow (9**9**9) doesn't give Inf"
+        if $here =~ /^(?:hpux 10|os390)/;
     is(9**9**9, $PInf, "9**9**9 is Inf");
 }
 
 SKIP: {
-    my @FInf = qw(Info Infiniti Infinityz);
+    my @FInf = qw(Infinite Info Inf123 Infiniti Infinityz);
     if ($Config{usequadmath}) {
         skip "quadmath strtoflt128() accepts false infinities", scalar @FInf;
     }
-    # Silence "isn't numeric in addition", that's kind of the point.
-    local $^W = 0;
     for my $i (@FInf) {
-        cmp_ok("$i" + 0, '==', 0, "false infinity $i");
+        # Silence "isn't numeric in addition", that's kind of the point.
+        local $^W = 0;
+        cmp_ok("$i" + 0, '==', $PInf, "false infinity $i");
     }
 }
 
+{
+    # Silence "Non-finite repeat count", that is tested elsewhere.
+    local $^W = 0;
+    is("a" x $PInf, "", "x +Inf");
+    is("a" x $NInf, "", "x -Inf");
+}
+
+{
+    eval 'for my $x (0..$PInf) { last }';
+    like($@, qr/Range iterator outside integer range/, "0..+Inf fails");
+
+    eval 'for my $x ($NInf..0) { last }';
+    like($@, qr/Range iterator outside integer range/, "-Inf..0 fails");
+}
+
 # === NaN ===
 
 cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)");
@@ -204,8 +278,11 @@ ok($NaN eq $NaN, "NaN is NaN stringifically");
 
 is("$NaN", "NaN", "$NaN value stringifies as NaN");
 
-is("+NaN" + 0, "NaN", "+NaN is NaN");
-is("-NaN" + 0, "NaN", "-NaN is NaN");
+{
+    local $^W = 0; # warning-ness tested later.
+    is("+NaN" + 0, "NaN", "+NaN is NaN");
+    is("-NaN" + 0, "NaN", "-NaN is NaN");
+}
 
 is($NaN + 0, $NaN, "NaN + zero is NaN");
 
@@ -215,22 +292,44 @@ is($NaN * 2, $NaN, "twice NaN is NaN");
 is($NaN / 2, $NaN, "half of NaN is NaN");
 
 is($NaN * $NaN, $NaN, "NaN * NaN is NaN");
-is($NaN / $NaN, $NaN, "NaN / NaN is NaN");
+SKIP: {
+    if ($NaN == 0) {
+        skip "NaN looks like zero, avoiding dividing by it", 1;
+    }
+    is($NaN / $NaN, $NaN, "NaN / NaN is NaN");
+}
 
 for my $f (@printf_fmt) {
     is(sprintf("%$f", $NaN), "NaN", "$NaN sprintf %$f is NaN");
 }
 
+is(sprintf("%+g", $NaN), "NaN", "$NaN sprintf %+g");
+
+is(sprintf("%4g",  $NaN), " NaN", "$NaN sprintf %4g");
+is(sprintf("%-4g", $NaN), "NaN ", "$NaN sprintf %-4g");
+
+is(sprintf("%+-5g", $NaN), "NaN  ", "$NaN sprintf %+-5g");
+is(sprintf("%-+5g", $NaN), "NaN  ", "$NaN sprintf %-+5g");
+
 ok(!defined eval { $a = sprintf("%c", $NaN)}, "sprintf %c NaN undef");
 like($@, qr/Cannot printf/, "$NaN sprintf fails");
+ok(!defined eval { $a = sprintf("%c", "NaN")},
+  "sprintf %c stringy NaN undef");
+like($@, qr/Cannot printf/, "stringy $NaN sprintf %c fails");
 
 ok(!defined eval { $a = chr($NaN) }, "chr NaN undef");
 like($@, qr/Cannot chr/, "NaN chr() fails");
+ok(!defined eval { $a = chr("NaN") }, "chr stringy NaN undef");
+like($@, qr/Cannot chr/, "stringy NaN chr() fails");
 
 for my $f (@packi_fmt) {
     ok(!defined eval { $a = pack($f, $NaN) }, "pack $f NaN undef");
     like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
          "NaN pack $f fails");
+    ok(!defined eval { $a = pack($f, "NaN") },
+       "pack $f stringy NaN undef");
+    like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
+         "stringy NaN pack $f fails");
 }
 
 for my $f (@packf_fmt) {
@@ -239,9 +338,23 @@ for my $f (@packf_fmt) {
     cmp_ok($b, '!=', $b, "pack $f NaN not-equals $NaN");
 }
 
+for my $f (@packs_fmt) {
+    ok(defined eval { $a = pack($f, $NaN) }, "pack $f NaN defined");
+    is($a, pack($f, "NaN"), "pack $f NaN same as 'NaN'");
+}
+
+is eval { unpack "p", pack 'p', $NaN }, "NaN", "pack p +NaN";
+is eval { unpack "P3", pack 'P', $NaN }, "NaN", "pack P +NaN";
+
 for my $i (@NaN) {
-    cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
-    is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
+    if (($i =~ /snan/i || $i =~ /nans/i) &&
+        (($i + 0) eq $PInf || ($i + 0 eq $NInf))) {
+        # Crazy but apparently true: signaling nan with zero payload
+        # can be Inf or -Inf on some platforms (like x86).
+    } else {
+        cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
+        is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
+    }
 }
 
 ok(!($NaN <  0), "NaN is not lt zero");
@@ -280,14 +393,29 @@ SKIP: {
 is(sin($NaN), $NaN, "sin(NaN) is NaN");
 is(rand($NaN), $NaN, "rand(NaN) is NaN");
 
-SKIP: {
+TODO: {
+    local $::TODO;
     my $here = "$^O $Config{osvers}";
-    if ($here =~ /^hpux 10/) {
-        skip "$here: pow doesn't generate Inf, so sin(Inf) won't happen", 1;
-    }
+    $::TODO = "$here: pow (9**9**9) doesn't give Inf"
+        if $here =~ /^(?:hpux 10|os390)/;
     is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN");
 }
 
+SKIP: {
+    my @FNaN = qw(NaX XNAN Ind Inx);
+    # Silence "isn't numeric in addition", that's kind of the point.
+    local $^W = 0;
+    for my $i (@FNaN) {
+        cmp_ok("$i" + 0, '==', 0, "false nan $i");
+    }
+}
+
+{
+    # Silence "Non-finite repeat count", that is tested elsewhere.
+    local $^W = 0;
+    is("a" x $NaN, "", "x NaN");
+}
+
 # === Tests combining Inf and NaN ===
 
 # is() okay with $NaN because it uses eq.
@@ -308,4 +436,192 @@ ok(!($NaN >  $NInf), "NaN is not gt -Inf");
 
 is(sin($PInf), $NaN, "sin(+Inf) is NaN");
 
+{
+    eval 'for my $x (0..$NaN) { last }';
+    like($@, qr/Range iterator outside integer range/, "0..NaN fails");
+
+    eval 'for my $x ($NaN..0) { last }';
+    like($@, qr/Range iterator outside integer range/, "NaN..0 fails");
+}
+
+# === Overflows and Underflows ===
+
+# 1e9999 (and 1e-9999) are large (and small) enough for even
+# IEEE quadruple precision (magnitude 10**4932, and 10**-4932).
+
+cmp_ok(1e9999,     '==', $PInf, "overflow to +Inf (compile time)");
+cmp_ok('1e9999',   '==', $PInf, "overflow to +Inf (runtime)");
+cmp_ok(-1e9999,    '==', $NInf, "overflow to -Inf (compile time)");
+cmp_ok('-1e9999',  '==', $NInf, "overflow to -Inf (runtime)");
+cmp_ok(1e-9999,    '==', 0,     "underflow to 0 (compile time) from pos");
+cmp_ok('1e-9999',  '==', 0,     "underflow to 0 (runtime) from pos");
+cmp_ok(-1e-9999,   '==', 0,     "underflow to 0 (compile time) from neg");
+cmp_ok('-1e-9999', '==', 0,     "underflow to 0 (runtime) from neg");
+
+# === Warnings triggered when and only when appropriate ===
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    local $^W = 1;
+
+    my $T =
+        [
+         [ "inf",          0, $PInf ],
+         [ "infinity",     0, $PInf ],
+         [ "infxy",        1, $PInf ],
+         [ "inf34",        1, $PInf ],
+         [ "1.#INF",       0, $PInf ],
+         [ "1.#INFx",      1, $PInf ],
+         [ "1.#INF00",     0, $PInf ],
+         [ "1.#INFxy",     1, $PInf ],
+         [ " inf",         0, $PInf ],
+         [ "inf ",         0, $PInf ],
+         [ " inf ",        0, $PInf ],
+
+         [ "nan",          0, $NaN ],
+         [ "nanxy",        1, $NaN ],
+         [ "nan34",        1, $NaN ],
+         [ "nan0x34",      1, $NaN ],
+         [ "nanq",         0, $NaN ],
+         # [ "nans",         0, $NaN, $PInf ], # Odd but valid.
+         [ "nanx",         1, $NaN ],
+         [ "nanqy",        1, $NaN ],
+         [ "nan(123)",     0, $NaN ],
+         [ "nan(0x123)",   0, $NaN ],
+         [ "nan(123xy)",   1, $NaN ],
+         [ "nan(0x123xy)", 1, $NaN ],
+         [ "nanq(123)",    0, $NaN ],
+         [ "1.#NANQ",      0, $NaN ],
+         [ "1.#QNAN",      0, $NaN ],
+         [ "1.#NANQx",     1, $NaN ],
+         [ "1.#QNANx",     1, $NaN ],
+         [ "1.#IND",       0, $NaN ],
+         [ "1.#IND00",     0, $NaN ],
+         [ "1.#INDxy",     1, $NaN ],
+         [ " nan",         0, $NaN ],
+         [ "nan ",         0, $NaN ],
+         [ " nan ",        0, $NaN ],
+        ];
+
+    for my $t (@$T) {
+        print "# '$t->[0]' compile time\n";
+        my $a;
+        $w = '';
+        eval '$a = "'.$t->[0].'" + 1';
+        is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]");
+        if ($t->[1]) {
+            like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/,
+                 "$t->[2] numify warn");
+        } else {
+            is($w, "", "no warning expected");
+        }
+        print "# '$t->[0]' runtime\n";
+        my $n = $t->[0];
+        my $b;
+        $w = '';
+        eval '$b = $n + 1';
+        is("$b", "$t->[2]", "$n plus one is $t->[2]");
+        if ($t->[1]) {
+            like($w, qr/^Argument \Q"$n"\E isn't numeric/,
+                 "$n numify warn");
+        } else {
+            is($w, "", "no warning expected");
+        }
+    }
+}
+
+# === NaN quiet/signaling/payload ===
+
+# The '#' or 'the alt' of printf knows how to prettyprint NaN payloads.
+
+SKIP: {
+    # Test only on certain known platforms since the features
+    # are not that well standardized.
+    unless (
+        ((
+          $^O eq 'linux'
+          ||
+          $^O eq 'darwin' # OS X
+          ||
+          $^O eq 'freebsd'
+         )
+         &&
+        (
+         (
+          $Config{nvsize} == 8 && # double
+          $Config{doublekind} == 3 # IEEE double little-endian (x86)
+         )
+         ||
+         (
+          $Config{uselongdouble} &&
+          $Config{nvsize} == 16 && # long double
+          $Config{longdblkind} == 3 # x86 80-bit extended precision
+         )
+        ))
+        ||
+        ($^O eq 'solaris' &&
+         $Config{nvsize} == 8 && # double
+         ($Config{uvsize} == 4 # 32-bit
+          ||
+          $Config{uvsize} == 8 # 64-bit (-Duse64bitint)
+         ) &&
+         $Config{doublesize} == 8 &&
+         $Config{doublekind} == 4 # IEEE double big-endian (sparc)
+        )
+        ||
+        ($^O eq 'hpux' &&
+         $Config{nvsize} == 8 && # double
+         $Config{uvsize} == 4 && # 32-bit
+         $Config{doublesize} == 8 &&
+         $Config{doublekind} == 4 # IEEE double big-endian (hppa)
+         )
+        ||
+        ($^O eq 'dec_osf' && # Digital UNIX aka Tru64
+         $Config{nvsize} == 8 && # double
+         $Config{uvsize} == 8 && # 32-bit
+         $Config{doublesize} == 8 &&
+         $Config{doublekind} == 3 # IEEE double little-endian (alpha)
+         )
+        ) {
+        my ($uselongdouble, $longdblsize, $longdblkind) =
+            $Config{uselongdouble} ?
+            ($Config{uselongdouble},
+             $Config{longdblsize},
+             $Config{longdblkind}) :
+            ('undef', 'undef', 'undef');
+        skip("skipping NaN specials testing on os=$^O, uvsize=$Config{uvsize}, nvsize=$Config{nvsize}, doublesize=$Config{doublesize}, doublekind=$Config{doublekind}, uselongdouble=$uselongdouble, longdblsize=$longdblsize, longdblkind=$longdblkind", 16);
+    }
+
+    is(sprintf("%#g", $NaN), "NaN(0x0)", "sprintf %#g");
+    is(sprintf("%#g", "nan"), "NaN(0x0)");
+    is(sprintf("%#g", "nanq"), "NaN(0x0)");
+    is(sprintf("%#g", "qnan"), "NaN(0x0)");
+
+    # This weirdness brought to you courtesy of asymmetry in the IEEE spec.
+    # In x86 style nans, nans(0) is equal to infinity or -infinity.
+    # In mips/hppa style, nans(0) is nans(0).
+    like(sprintf("%#g", "nans"), qr/^(?:-?Inf|NaNs\(0x0\))$/);
+    like(sprintf("%#g", "snan"), qr/^(?:-?Inf|NaNs\(0x0\))$/);
+
+    is(sprintf("%#g", "nan(12345)"), "NaN(0x3039)");
+    is(sprintf("%#g", "nan(0b101101)"), "NaN(0x2d)");
+    is(sprintf("%#g", "nan(0x12345)"), "NaN(0x12345)");
+    is(sprintf("%#g", "nanq(0x123EF)"), "NaN(0x123ef)");
+    is(sprintf("%#g", "nans(0x12345)"), "NaNs(0x12345)");
+    is(sprintf("%#g", "snan(0x12345)"), "NaNs(0x12345)");
+
+    is(sprintf("%#G", "nanq(0x123ef)"), "NaN(0X123EF)");
+
+  SKIP: {
+      if (ord('A') == 65) { # ASCII
+          is(sprintf("%#g", "nan('obot')"), "NaN(0x6f626f74)", "nanobot");
+      } elsif (ord('A') == 193) { # EBCDIC
+          is(sprintf("%#g", "nan('obot')"), "NaN(0x968296a3)", "nanobot");
+      } else {
+          skip "unknown encoding", 1;
+    }
+}
+
+}
+
 done_testing();