t/op/infnan.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10
  11 use Config;
  12
  13 BEGIN {
  14     if ($^O eq 'aix' && $Config{uselongdouble}) {
  15         # FWIW: NaN actually seems to be working decently,
  16         # but Inf is completely broken (e.g. Inf + 0 -> NaN).
  17         skip_all "$^O with long doubles does not have sane inf/nan";
  18     }
  19 }
  20
  21 my $PInf = "Inf"  + 0;
  22 my $NInf = "-Inf" + 0;
  23 my $NaN  = "NaN"  + 0;
  24
  25 my @PInf = ("Inf", "inf", "INF", "+Inf",
  26             "Infinity", "INFINITE",
  27             "1.#INF", "1#INF");
  28 my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf;
  29
  30 my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS",
  31            "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND",
  32            "NaN123", "NAN(123)", "nan%",
  33            "nanonano"); # RIP, Robin Williams.
  34
  35 my @printf_fmt = qw(e f g a d u o i b x p);
  36 my @packi_fmt = qw(c C s S l L i I n N v V j J w W U);
  37 my @packf_fmt = qw(f d F);
  38 my @packs_fmt = qw(a4 A4 Z5 b20 B20 h10 H10 u);
  39
  40 if ($Config{ivsize} == 8) {
  41     push @packi_fmt, qw(q Q);
  42 }
  43
  44 if ($Config{uselongdouble} && $Config{nvsize} > $Config{doublesize}) {
  45     push @packf_fmt, 'D';
  46 }
  47
  48 # === Inf tests ===
  49
  50 cmp_ok($PInf, '>', 0, "positive infinity");
  51 cmp_ok($NInf, '<', 0, "negative infinity");
  52
  53 cmp_ok($PInf, '>', $NInf, "positive > negative");
  54 cmp_ok($NInf, '==', -$PInf, "negative == -positive");
  55 cmp_ok(-$NInf, '==', $PInf, "--negative == positive");
  56
  57 is($PInf,  "Inf", "$PInf value stringifies as Inf");
  58 is($NInf, "-Inf", "$NInf value stringifies as -Inf");
  59
  60 cmp_ok($PInf + 0, '==', $PInf, "+Inf + zero is +Inf");
  61 cmp_ok($NInf + 0, '==', $NInf, "-Inf + zero is -Inf");
  62
  63 cmp_ok($PInf + 1, '==', $PInf, "+Inf + one is +Inf");
  64 cmp_ok($NInf + 1, '==', $NInf, "-Inf + one is -Inf");
  65
  66 cmp_ok($PInf + $PInf, '==', $PInf, "+Inf + Inf is +Inf");
  67 cmp_ok($NInf + $NInf, '==', $NInf, "-Inf - Inf is -Inf");
  68
  69 cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf");
  70 cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf");
  71
  72 cmp_ok($PInf * $PInf, '==', $PInf, "+Inf * +Inf is +Inf");
  73 cmp_ok($PInf * $NInf, '==', $NInf, "+Inf * -Inf is -Inf");
  74 cmp_ok($NInf * $PInf, '==', $NInf, "-Inf * +Inf is -Inf");
  75 cmp_ok($NInf * $NInf, '==', $PInf, "-Inf * -Inf is +Inf");
  76
  77 is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf");
  78 is(sprintf("%a", $PInf), "Inf", "$PInf sprintf %a is Inf");
  79
  80 for my $f (@printf_fmt) {
  81     is(sprintf("%$f", $PInf), "Inf", "$PInf sprintf %$f is Inf");
  82 }
  83
  84 ok(!defined eval { $a = sprintf("%c", $PInf)}, "sprintf %c +Inf undef");
  85 like($@, qr/Cannot printf/, "$PInf sprintf fails");
  86 ok(!defined eval { $a = sprintf("%c", "Inf")},
  87   "stringy sprintf %c +Inf undef");
  88 like($@, qr/Cannot printf/, "stringy $PInf sprintf fails");
  89
  90 ok(!defined eval { $a = chr($PInf) }, "chr(+Inf) undef");
  91 like($@, qr/Cannot chr/, "+Inf chr() fails");
  92 ok(!defined eval { $a = chr("Inf") }, "chr(stringy +Inf) undef");
  93 like($@, qr/Cannot chr/, "stringy +Inf chr() fails");
  94
  95 ok(!defined eval { $a = sprintf("%c", $NInf)}, "sprintf %c -Inf undef");
  96 like($@, qr/Cannot printf/, "$NInf sprintf fails");
  97 ok(!defined eval { $a = sprintf("%c", "-Inf")},
  98   "sprintf %c stringy -Inf undef");
  99 like($@, qr/Cannot printf/, "stringy $NInf sprintf fails");
 100
 101 ok(!defined eval { $a = chr($NInf) }, "chr(-Inf) undef");
 102 like($@, qr/Cannot chr/, "-Inf chr() fails");
 103 ok(!defined eval { $a = chr("-Inf") }, "chr(stringy -Inf) undef");
 104 like($@, qr/Cannot chr/, "stringy -Inf chr() fails");
 105
 106 for my $f (@packi_fmt) {
 107     undef $a;
 108     ok(!defined eval { $a = pack($f, $PInf) }, "pack $f +Inf undef");
 109     like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
 110          "+Inf pack $f fails");
 111     undef $a;
 112     ok(!defined eval { $a = pack($f, "Inf") },
 113       "pack $f stringy +Inf undef");
 114     like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
 115          "stringy +Inf pack $f fails");
 116     undef $a;
 117     ok(!defined eval { $a = pack($f, $NInf) }, "pack $f -Inf undef");
 118     like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
 119          "-Inf pack $f fails");
 120     undef $a;
 121     ok(!defined eval { $a = pack($f, "-Inf") },
 122       "pack $f stringy -Inf undef");
 123     like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
 124          "stringy -Inf pack $f fails");
 125 }
 126
 127 for my $f (@packf_fmt) {
 128     undef $a;
 129     undef $b;
 130     ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
 131     eval { $b = unpack($f, $a) };
 132     cmp_ok($b, '==', $PInf, "pack $f +Inf equals $PInf");
 133
 134     undef $a;
 135     undef $b;
 136     ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
 137     eval { $b = unpack($f, $a) };
 138     cmp_ok($b, '==', $NInf, "pack $f -Inf equals $NInf");
 139 }
 140
 141 for my $f (@packs_fmt) {
 142     undef $a;
 143     ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
 144     is($a, pack($f, "Inf"), "pack $f +Inf same as 'Inf'");
 145
 146     undef $a;
 147     ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
 148     is($a, pack($f, "-Inf"), "pack $f -Inf same as 'Inf'");
 149 }
 150
 151 is eval { unpack "p", pack 'p', $PInf }, "Inf", "pack p +Inf";
 152 is eval { unpack "P3", pack 'P', $PInf }, "Inf", "pack P +Inf";
 153 is eval { unpack "p", pack 'p', $NInf }, "-Inf", "pack p -Inf";
 154 is eval { unpack "P4", pack 'P', $NInf }, "-Inf", "pack P -Inf";
 155
 156 for my $i (@PInf) {
 157     cmp_ok($i + 0 , '==', $PInf, "$i is +Inf");
 158     cmp_ok($i, '>', 0, "$i is positive");
 159     is("@{[$i+0]}", "Inf", "$i value stringifies as Inf");
 160 }
 161
 162 for my $i (@NInf) {
 163     cmp_ok($i + 0, '==', $NInf, "$i is -Inf");
 164     cmp_ok($i, '<', 0, "$i is negative");
 165     is("@{[$i+0]}", "-Inf", "$i value stringifies as -Inf");
 166 }
 167
 168 is($PInf + $PInf, $PInf, "+Inf plus +Inf is +Inf");
 169 is($NInf + $NInf, $NInf, "-Inf plus -Inf is -Inf");
 170
 171 is(1/$PInf, 0, "one per +Inf is zero");
 172 is(1/$NInf, 0, "one per -Inf is zero");
 173
 174 my ($PInfPP, $PInfMM) = ($PInf, $PInf);
 175 my ($NInfPP, $NInfMM) = ($NInf, $NInf);;
 176 $PInfPP++;
 177 $PInfMM--;
 178 $NInfPP++;
 179 $NInfMM--;
 180 is($PInfPP, $PInf, "+Inf++ is +Inf");
 181 is($PInfMM, $PInf, "+Inf-- is +Inf");
 182 is($NInfPP, $NInf, "-Inf++ is -Inf");
 183 is($NInfMM, $NInf, "-Inf-- is -Inf");
 184
 185 ok($PInf, "+Inf is true");
 186 ok($NInf, "-Inf is true");
 187
 188 is(abs($PInf), $PInf, "abs(+Inf) is +Inf");
 189 is(abs($NInf), $PInf, "abs(-Inf) is +Inf");
 190
 191 # One could argue of NaN as the result.
 192 is(int($PInf), $PInf, "int(+Inf) is +Inf");
 193 is(int($NInf), $NInf, "int(-Inf) is -Inf");
 194
 195 is(sqrt($PInf), $PInf, "sqrt(+Inf) is +Inf");
 196 # sqrt $NInf doesn't work because negative is caught
 197
 198 is(exp($PInf), $PInf, "exp(+Inf) is +Inf");
 199 is(exp($NInf), 0, "exp(-Inf) is zero");
 200
 201 SKIP: {
 202     if ($PInf == 0) {
 203         skip "if +Inf == 0 cannot log(+Inf)", 1;
 204     }
 205     is(log($PInf), $PInf, "log(+Inf) is +Inf");
 206 }
 207 # log $NInf doesn't work because negative is caught
 208
 209 is(rand($PInf), $PInf, "rand(+Inf) is +Inf");
 210 is(rand($NInf), $NInf, "rand(-Inf) is -Inf");
 211
 212 # XXX Bit operations?
 213 # +Inf & 1 == +Inf?
 214 # +Inf | 1 == +Inf?
 215 # +Inf ^ 1 == +Inf?
 216 # ~+Inf    == 0? or NaN?
 217 # -Inf ... ???
 218 # NaN & 1 == NaN?
 219 # NaN | 1 == NaN?
 220 # NaN ^ 1 == NaN?
 221 # ~NaN    == NaN???
 222 # Or just declare insanity and die?
 223
 224 TODO: {
 225     local $::TODO;
 226     my $here = "$^O $Config{osvers}";
 227     $::TODO = "$here: pow (9**9**9) doesn't give Inf"
 228         if $here =~ /^(?:hpux 10|os390)/;
 229     is(9**9**9, $PInf, "9**9**9 is Inf");
 230 }
 231
 232 SKIP: {
 233     my @FInf = qw(Info Infiniti Infinityz);
 234     if ($Config{usequadmath}) {
 235         skip "quadmath strtoflt128() accepts false infinities", scalar @FInf;
 236     }
 237     # Silence "isn't numeric in addition", that's kind of the point.
 238     local $^W = 0;
 239     for my $i (@FInf) {
 240         cmp_ok("$i" + 0, '==', 0, "false infinity $i");
 241     }
 242 }
 243
 244 {
 245     # Silence "Non-finite repeat count", that is tested elsewhere.
 246     local $^W = 0;
 247     is("a" x $PInf, "", "x +Inf");
 248     is("a" x $NInf, "", "x -Inf");
 249 }
 250
 251 {
 252     eval 'for my $x (0..$PInf) { last }';
 253     like($@, qr/Range iterator outside integer range/, "0..+Inf fails");
 254
 255     eval 'for my $x ($NInf..0) { last }';
 256     like($@, qr/Range iterator outside integer range/, "-Inf..0 fails");
 257 }
 258
 259 # === NaN ===
 260
 261 cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)");
 262 ok($NaN eq $NaN, "NaN is NaN stringifically");
 263
 264 is("$NaN", "NaN", "$NaN value stringifies as NaN");
 265
 266 is("+NaN" + 0, "NaN", "+NaN is NaN");
 267 is("-NaN" + 0, "NaN", "-NaN is NaN");
 268
 269 is($NaN + 0, $NaN, "NaN + zero is NaN");
 270
 271 is($NaN + 1, $NaN, "NaN + one is NaN");
 272
 273 is($NaN * 2, $NaN, "twice NaN is NaN");
 274 is($NaN / 2, $NaN, "half of NaN is NaN");
 275
 276 is($NaN * $NaN, $NaN, "NaN * NaN is NaN");
 277 is($NaN / $NaN, $NaN, "NaN / NaN is NaN");
 278
 279 for my $f (@printf_fmt) {
 280     is(sprintf("%$f", $NaN), "NaN", "$NaN sprintf %$f is NaN");
 281 }
 282
 283 ok(!defined eval { $a = sprintf("%c", $NaN)}, "sprintf %c NaN undef");
 284 like($@, qr/Cannot printf/, "$NaN sprintf fails");
 285 ok(!defined eval { $a = sprintf("%c", "NaN")},
 286   "sprintf %c stringy NaN undef");
 287 like($@, qr/Cannot printf/, "stringy $NaN sprintf fails");
 288
 289 ok(!defined eval { $a = chr($NaN) }, "chr NaN undef");
 290 like($@, qr/Cannot chr/, "NaN chr() fails");
 291 ok(!defined eval { $a = chr("NaN") }, "chr stringy NaN undef");
 292 like($@, qr/Cannot chr/, "stringy NaN chr() fails");
 293
 294 for my $f (@packi_fmt) {
 295     ok(!defined eval { $a = pack($f, $NaN) }, "pack $f NaN undef");
 296     like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
 297          "NaN pack $f fails");
 298     ok(!defined eval { $a = pack($f, "NaN") },
 299        "pack $f stringy NaN undef");
 300     like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
 301          "stringy NaN pack $f fails");
 302 }
 303
 304 for my $f (@packf_fmt) {
 305     ok(defined eval { $a = pack($f, $NaN) }, "pack $f NaN defined");
 306     eval { $b = unpack($f, $a) };
 307     cmp_ok($b, '!=', $b, "pack $f NaN not-equals $NaN");
 308 }
 309
 310 for my $f (@packs_fmt) {
 311     ok(defined eval { $a = pack($f, $NaN) }, "pack $f NaN defined");
 312     is($a, pack($f, "NaN"), "pack $f NaN same as 'NaN'");
 313 }
 314
 315 is eval { unpack "p", pack 'p', $NaN }, "NaN", "pack p +NaN";
 316 is eval { unpack "P3", pack 'P', $NaN }, "NaN", "pack P +NaN";
 317
 318 for my $i (@NaN) {
 319     cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
 320     is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
 321 }
 322
 323 ok(!($NaN <  0), "NaN is not lt zero");
 324 ok(!($NaN == 0), "NaN is not == zero");
 325 ok(!($NaN >  0), "NaN is not gt zero");
 326
 327 ok(!($NaN < $NaN), "NaN is not lt NaN");
 328 ok(!($NaN > $NaN), "NaN is not gt NaN");
 329
 330 # is() okay with $NaN because it uses eq.
 331 is($NaN * 0, $NaN, "NaN times zero is NaN");
 332 is($NaN * 2, $NaN, "NaN times two is NaN");
 333
 334 my ($NaNPP, $NaNMM) = ($NaN, $NaN);
 335 $NaNPP++;
 336 $NaNMM--;
 337 is($NaNPP, $NaN, "+NaN++ is NaN");
 338 is($NaNMM, $NaN, "+NaN-- is NaN");
 339
 340 # You might find this surprising (isn't NaN kind of like of undef?)
 341 # but this is how it is.
 342 ok($NaN, "NaN is true");
 343
 344 is(abs($NaN), $NaN, "abs(NaN) is NaN");
 345 is(int($NaN), $NaN, "int(NaN) is NaN");
 346 is(sqrt($NaN), $NaN, "sqrt(NaN) is NaN");
 347 is(exp($NaN), $NaN, "exp(NaN) is NaN");
 348
 349 SKIP: {
 350     if ($NaN == 0) {
 351         skip "if +NaN == 0 cannot log(+NaN)", 1;
 352     }
 353     is(log($NaN), $NaN, "log(NaN) is NaN");
 354 }
 355
 356 is(sin($NaN), $NaN, "sin(NaN) is NaN");
 357 is(rand($NaN), $NaN, "rand(NaN) is NaN");
 358
 359 TODO: {
 360     local $::TODO;
 361     my $here = "$^O $Config{osvers}";
 362     $::TODO = "$here: pow (9**9**9) doesn't give Inf"
 363         if $here =~ /^(?:hpux 10|os390)/;
 364     is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN");
 365 }
 366
 367 SKIP: {
 368     my @FNaN = qw(NaX XNAN Ind Inx);
 369     # Silence "isn't numeric in addition", that's kind of the point.
 370     local $^W = 0;
 371     for my $i (@FNaN) {
 372         cmp_ok("$i" + 0, '==', 0, "false nan $i");
 373     }
 374 }
 375
 376 {
 377     # Silence "Non-finite repeat count", that is tested elsewhere.
 378     local $^W = 0;
 379     is("a" x $NaN, "", "x NaN");
 380 }
 381
 382 # === Tests combining Inf and NaN ===
 383
 384 # is() okay with $NaN because it uses eq.
 385 is($PInf * 0,     $NaN, "Inf times zero is NaN");
 386 is($PInf * $NaN,  $NaN, "Inf times NaN is NaN");
 387 is($PInf + $NaN,  $NaN, "Inf plus NaN is NaN");
 388 is($PInf - $PInf, $NaN, "Inf minus inf is NaN");
 389 is($PInf / $PInf, $NaN, "Inf div inf is NaN");
 390 is($PInf % $PInf, $NaN, "Inf mod inf is NaN");
 391
 392 ok(!($NaN <  $PInf), "NaN is not lt +Inf");
 393 ok(!($NaN == $PInf), "NaN is not eq +Inf");
 394 ok(!($NaN >  $PInf), "NaN is not gt +Inf");
 395
 396 ok(!($NaN <  $NInf), "NaN is not lt -Inf");
 397 ok(!($NaN == $NInf), "NaN is not eq -Inf");
 398 ok(!($NaN >  $NInf), "NaN is not gt -Inf");
 399
 400 is(sin($PInf), $NaN, "sin(+Inf) is NaN");
 401
 402 {
 403     eval 'for my $x (0..$NaN) { last }';
 404     like($@, qr/Range iterator outside integer range/, "0..NaN fails");
 405
 406     eval 'for my $x ($NaN..0) { last }';
 407     like($@, qr/Range iterator outside integer range/, "NaN..0 fails");
 408 }
 409
 410 # === Overflows and Underflows ===
 411
 412 # 1e9999 (and 1e-9999) are large (and small) enough for even
 413 # IEEE quadruple precision (magnitude 10**4932, and 10**-4932).
 414
 415 cmp_ok(1e9999,     '==', $PInf, "overflow to +Inf (compile time)");
 416 cmp_ok('1e9999',   '==', $PInf, "overflow to +Inf (runtime)");
 417 cmp_ok(-1e9999,    '==', $NInf, "overflow to -Inf (compile time)");
 418 cmp_ok('-1e9999',  '==', $NInf, "overflow to -Inf (runtime)");
 419 cmp_ok(1e-9999,    '==', 0,     "underflow to 0 (compile time) from pos");
 420 cmp_ok('1e-9999',  '==', 0,     "underflow to 0 (runtime) from pos");
 421 cmp_ok(-1e-9999,   '==', 0,     "underflow to 0 (compile time) from neg");
 422 cmp_ok('-1e-9999', '==', 0,     "underflow to 0 (runtime) from neg");
 423
 424 done_testing();