X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8d2f77d8a28a02eedb0d7cd7a8aff358b6177739..d24e3eb1402c1294265f99342e2ec0ecfd0f5d34:/t/op/infnan.t?ds=sidebyside

diff --git a/t/op/infnan.t b/t/op/infnan.t
index 7627135..1f68cff 100644
--- a/t/op/infnan.t
+++ b/t/op/infnan.t
@@ -2,8 +2,8 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
     require './test.pl';
+    set_up_inc('../lib');
 }
 
 use strict;
@@ -16,21 +16,27 @@ BEGIN {
         # but Inf is completely broken (e.g. Inf + 0 -> NaN).
         skip_all "$^O with long doubles does not have sane inf/nan";
     }
+    unless ($Config{d_double_has_inf} && $Config{d_double_has_nan}) {
+        skip_all "the doublekind $Config{doublekind} does not have inf/nan";
+    }
 }
 
 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(c C s S l L i I n N v V j J w W U);
@@ -81,11 +87,23 @@ 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 fails");
+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");
@@ -96,7 +114,7 @@ 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 fails");
+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");
@@ -230,14 +248,14 @@ TODO: {
 }
 
 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");
     }
 }
 
@@ -248,6 +266,14 @@ SKIP: {
     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)");
@@ -255,8 +281,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");
 
@@ -266,17 +295,30 @@ 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 fails");
+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");
@@ -391,6 +433,14 @@ 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
@@ -405,4 +455,77 @@ 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 ],
+         [ "nanq",         0, $NaN ],
+         [ "nans",         0, $NaN ],
+         [ "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 ],
+         [ "nan(123",      1, $NaN ],
+         [ "nan(",         1, $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");
+        }
+    }
+}
+
 done_testing();