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;
  24 {
  25     local $^W = 0; # warning-ness tested later.
  26     $NaN  = "NaN" + 0;
  27 }
  28
  29 my @PInf = ("Inf", "inf", "INF", "+Inf",
  30             "Infinity",
  31             "1.#INF", "1#INF", "1.#INF00");
  32 my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf;
  33
  34 my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS",
  35            "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND", "1.#IND00",
  36            "NAN(123)");
  37
  38 my @printf_fmt = qw(e f g a d u o i b x p);
  39 my @packi_fmt = qw(c C s S l L i I n N v V j J w W U);
  40 my @packf_fmt = qw(f d F);
  41 my @packs_fmt = qw(a4 A4 Z5 b20 B20 h10 H10 u);
  42
  43 if ($Config{ivsize} == 8) {
  44     push @packi_fmt, qw(q Q);
  45 }
  46
  47 if ($Config{uselongdouble} && $Config{nvsize} > $Config{doublesize}) {
  48     push @packf_fmt, 'D';
  49 }
  50
  51 # === Inf tests ===
  52
  53 cmp_ok($PInf, '>', 0, "positive infinity");
  54 cmp_ok($NInf, '<', 0, "negative infinity");
  55
  56 cmp_ok($PInf, '>', $NInf, "positive > negative");
  57 cmp_ok($NInf, '==', -$PInf, "negative == -positive");
  58 cmp_ok(-$NInf, '==', $PInf, "--negative == positive");
  59
  60 is($PInf,  "Inf", "$PInf value stringifies as Inf");
  61 is($NInf, "-Inf", "$NInf value stringifies as -Inf");
  62
  63 cmp_ok($PInf + 0, '==', $PInf, "+Inf + zero is +Inf");
  64 cmp_ok($NInf + 0, '==', $NInf, "-Inf + zero is -Inf");
  65
  66 cmp_ok($PInf + 1, '==', $PInf, "+Inf + one is +Inf");
  67 cmp_ok($NInf + 1, '==', $NInf, "-Inf + one is -Inf");
  68
  69 cmp_ok($PInf + $PInf, '==', $PInf, "+Inf + Inf is +Inf");
  70 cmp_ok($NInf + $NInf, '==', $NInf, "-Inf - Inf is -Inf");
  71
  72 cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf");
  73 cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf");
  74
  75 cmp_ok($PInf * $PInf, '==', $PInf, "+Inf * +Inf is +Inf");
  76 cmp_ok($PInf * $NInf, '==', $NInf, "+Inf * -Inf is -Inf");
  77 cmp_ok($NInf * $PInf, '==', $NInf, "-Inf * +Inf is -Inf");
  78 cmp_ok($NInf * $NInf, '==', $PInf, "-Inf * -Inf is +Inf");
  79
  80 is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf");
  81 is(sprintf("%a", $PInf), "Inf", "$PInf sprintf %a is Inf");
  82
  83 for my $f (@printf_fmt) {
  84     is(sprintf("%$f", $PInf), "Inf", "$PInf sprintf %$f is Inf");
  85 }
  86
  87 is(sprintf("%+g", $PInf), "+Inf", "$PInf sprintf %+g");
  88 is(sprintf("%+g", $NInf), "-Inf", "$PInf sprintf %+g");
  89
  90 is(sprintf("%4g",  $PInf), " Inf", "$PInf sprintf %4g");
  91 is(sprintf("%-4g", $PInf), "Inf ", "$PInf sprintf %-4g");
  92
  93 is(sprintf("%+-5g", $PInf), "+Inf ", "$PInf sprintf %+-5g");
  94 is(sprintf("%-+5g", $PInf), "+Inf ", "$PInf sprintf %-+5g");
  95
  96 is(sprintf("%-+5g", $NInf), "-Inf ", "$NInf sprintf %-+5g");
  97 is(sprintf("%+-5g", $NInf), "-Inf ", "$NInf sprintf %+-5g");
  98
  99 ok(!defined eval { $a = sprintf("%c", $PInf)}, "sprintf %c +Inf undef");
 100 like($@, qr/Cannot printf/, "$PInf sprintf fails");
 101 ok(!defined eval { $a = sprintf("%c", "Inf")},
 102   "stringy sprintf %c +Inf undef");
 103 like($@, qr/Cannot printf/, "stringy $PInf sprintf %c fails");
 104
 105 ok(!defined eval { $a = chr($PInf) }, "chr(+Inf) undef");
 106 like($@, qr/Cannot chr/, "+Inf chr() fails");
 107 ok(!defined eval { $a = chr("Inf") }, "chr(stringy +Inf) undef");
 108 like($@, qr/Cannot chr/, "stringy +Inf chr() fails");
 109
 110 ok(!defined eval { $a = sprintf("%c", $NInf)}, "sprintf %c -Inf undef");
 111 like($@, qr/Cannot printf/, "$NInf sprintf fails");
 112 ok(!defined eval { $a = sprintf("%c", "-Inf")},
 113   "sprintf %c stringy -Inf undef");
 114 like($@, qr/Cannot printf/, "stringy $NInf sprintf %c fails");
 115
 116 ok(!defined eval { $a = chr($NInf) }, "chr(-Inf) undef");
 117 like($@, qr/Cannot chr/, "-Inf chr() fails");
 118 ok(!defined eval { $a = chr("-Inf") }, "chr(stringy -Inf) undef");
 119 like($@, qr/Cannot chr/, "stringy -Inf chr() fails");
 120
 121 for my $f (@packi_fmt) {
 122     undef $a;
 123     ok(!defined eval { $a = pack($f, $PInf) }, "pack $f +Inf undef");
 124     like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
 125          "+Inf pack $f fails");
 126     undef $a;
 127     ok(!defined eval { $a = pack($f, "Inf") },
 128       "pack $f stringy +Inf undef");
 129     like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
 130          "stringy +Inf pack $f fails");
 131     undef $a;
 132     ok(!defined eval { $a = pack($f, $NInf) }, "pack $f -Inf undef");
 133     like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
 134          "-Inf pack $f fails");
 135     undef $a;
 136     ok(!defined eval { $a = pack($f, "-Inf") },
 137       "pack $f stringy -Inf undef");
 138     like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
 139          "stringy -Inf pack $f fails");
 140 }
 141
 142 for my $f (@packf_fmt) {
 143     undef $a;
 144     undef $b;
 145     ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
 146     eval { $b = unpack($f, $a) };
 147     cmp_ok($b, '==', $PInf, "pack $f +Inf equals $PInf");
 148
 149     undef $a;
 150     undef $b;
 151     ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
 152     eval { $b = unpack($f, $a) };
 153     cmp_ok($b, '==', $NInf, "pack $f -Inf equals $NInf");
 154 }
 155
 156 for my $f (@packs_fmt) {
 157     undef $a;
 158     ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
 159     is($a, pack($f, "Inf"), "pack $f +Inf same as 'Inf'");
 160
 161     undef $a;
 162     ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
 163     is($a, pack($f, "-Inf"), "pack $f -Inf same as 'Inf'");
 164 }
 165
 166 is eval { unpack "p", pack 'p', $PInf }, "Inf", "pack p +Inf";
 167 is eval { unpack "P3", pack 'P', $PInf }, "Inf", "pack P +Inf";
 168 is eval { unpack "p", pack 'p', $NInf }, "-Inf", "pack p -Inf";
 169 is eval { unpack "P4", pack 'P', $NInf }, "-Inf", "pack P -Inf";
 170
 171 for my $i (@PInf) {
 172     cmp_ok($i + 0 , '==', $PInf, "$i is +Inf");
 173     cmp_ok($i, '>', 0, "$i is positive");
 174     is("@{[$i+0]}", "Inf", "$i value stringifies as Inf");
 175 }
 176
 177 for my $i (@NInf) {
 178     cmp_ok($i + 0, '==', $NInf, "$i is -Inf");
 179     cmp_ok($i, '<', 0, "$i is negative");
 180     is("@{[$i+0]}", "-Inf", "$i value stringifies as -Inf");
 181 }
 182
 183 is($PInf + $PInf, $PInf, "+Inf plus +Inf is +Inf");
 184 is($NInf + $NInf, $NInf, "-Inf plus -Inf is -Inf");
 185
 186 is(1/$PInf, 0, "one per +Inf is zero");
 187 is(1/$NInf, 0, "one per -Inf is zero");
 188
 189 my ($PInfPP, $PInfMM) = ($PInf, $PInf);
 190 my ($NInfPP, $NInfMM) = ($NInf, $NInf);;
 191 $PInfPP++;
 192 $PInfMM--;
 193 $NInfPP++;
 194 $NInfMM--;
 195 is($PInfPP, $PInf, "+Inf++ is +Inf");
 196 is($PInfMM, $PInf, "+Inf-- is +Inf");
 197 is($NInfPP, $NInf, "-Inf++ is -Inf");
 198 is($NInfMM, $NInf, "-Inf-- is -Inf");
 199
 200 ok($PInf, "+Inf is true");
 201 ok($NInf, "-Inf is true");
 202
 203 is(abs($PInf), $PInf, "abs(+Inf) is +Inf");
 204 is(abs($NInf), $PInf, "abs(-Inf) is +Inf");
 205
 206 # One could argue of NaN as the result.
 207 is(int($PInf), $PInf, "int(+Inf) is +Inf");
 208 is(int($NInf), $NInf, "int(-Inf) is -Inf");
 209
 210 is(sqrt($PInf), $PInf, "sqrt(+Inf) is +Inf");
 211 # sqrt $NInf doesn't work because negative is caught
 212
 213 is(exp($PInf), $PInf, "exp(+Inf) is +Inf");
 214 is(exp($NInf), 0, "exp(-Inf) is zero");
 215
 216 SKIP: {
 217     if ($PInf == 0) {
 218         skip "if +Inf == 0 cannot log(+Inf)", 1;
 219     }
 220     is(log($PInf), $PInf, "log(+Inf) is +Inf");
 221 }
 222 # log $NInf doesn't work because negative is caught
 223
 224 is(rand($PInf), $PInf, "rand(+Inf) is +Inf");
 225 is(rand($NInf), $NInf, "rand(-Inf) is -Inf");
 226
 227 # XXX Bit operations?
 228 # +Inf & 1 == +Inf?
 229 # +Inf | 1 == +Inf?
 230 # +Inf ^ 1 == +Inf?
 231 # ~+Inf    == 0? or NaN?
 232 # -Inf ... ???
 233 # NaN & 1 == NaN?
 234 # NaN | 1 == NaN?
 235 # NaN ^ 1 == NaN?
 236 # ~NaN    == NaN???
 237 # Or just declare insanity and die?
 238
 239 TODO: {
 240     local $::TODO;
 241     my $here = "$^O $Config{osvers}";
 242     $::TODO = "$here: pow (9**9**9) doesn't give Inf"
 243         if $here =~ /^(?:hpux 10|os390)/;
 244     is(9**9**9, $PInf, "9**9**9 is Inf");
 245 }
 246
 247 SKIP: {
 248     my @FInf = qw(Infinite Info Inf123 Infiniti Infinityz);
 249     if ($Config{usequadmath}) {
 250         skip "quadmath strtoflt128() accepts false infinities", scalar @FInf;
 251     }
 252     for my $i (@FInf) {
 253         # Silence "isn't numeric in addition", that's kind of the point.
 254         local $^W = 0;
 255         cmp_ok("$i" + 0, '==', $PInf, "false infinity $i");
 256     }
 257 }
 258
 259 {
 260     # Silence "Non-finite repeat count", that is tested elsewhere.
 261     local $^W = 0;
 262     is("a" x $PInf, "", "x +Inf");
 263     is("a" x $NInf, "", "x -Inf");
 264 }
 265
 266 {
 267     eval 'for my $x (0..$PInf) { last }';
 268     like($@, qr/Range iterator outside integer range/, "0..+Inf fails");
 269
 270     eval 'for my $x ($NInf..0) { last }';
 271     like($@, qr/Range iterator outside integer range/, "-Inf..0 fails");
 272 }
 273
 274 # === NaN ===
 275
 276 cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)");
 277 ok($NaN eq $NaN, "NaN is NaN stringifically");
 278
 279 is("$NaN", "NaN", "$NaN value stringifies as NaN");
 280
 281 {
 282     local $^W = 0; # warning-ness tested later.
 283     is("+NaN" + 0, "NaN", "+NaN is NaN");
 284     is("-NaN" + 0, "NaN", "-NaN is NaN");
 285 }
 286
 287 is($NaN + 0, $NaN, "NaN + zero is NaN");
 288
 289 is($NaN + 1, $NaN, "NaN + one is NaN");
 290
 291 is($NaN * 2, $NaN, "twice NaN is NaN");
 292 is($NaN / 2, $NaN, "half of NaN is NaN");
 293
 294 is($NaN * $NaN, $NaN, "NaN * NaN is NaN");
 295 SKIP: {
 296     if ($NaN == 0) {
 297         skip "NaN looks like zero, avoiding dividing by it", 1;
 298     }
 299     is($NaN / $NaN, $NaN, "NaN / NaN is NaN");
 300 }
 301
 302 for my $f (@printf_fmt) {
 303     is(sprintf("%$f", $NaN), "NaN", "$NaN sprintf %$f is NaN");
 304 }
 305
 306 is(sprintf("%+g", $NaN), "NaN", "$NaN sprintf %+g");
 307
 308 is(sprintf("%4g",  $NaN), " NaN", "$NaN sprintf %4g");
 309 is(sprintf("%-4g", $NaN), "NaN ", "$NaN sprintf %-4g");
 310
 311 is(sprintf("%+-5g", $NaN), "NaN  ", "$NaN sprintf %+-5g");
 312 is(sprintf("%-+5g", $NaN), "NaN  ", "$NaN sprintf %-+5g");
 313
 314 ok(!defined eval { $a = sprintf("%c", $NaN)}, "sprintf %c NaN undef");
 315 like($@, qr/Cannot printf/, "$NaN sprintf fails");
 316 ok(!defined eval { $a = sprintf("%c", "NaN")},
 317   "sprintf %c stringy NaN undef");
 318 like($@, qr/Cannot printf/, "stringy $NaN sprintf %c fails");
 319
 320 ok(!defined eval { $a = chr($NaN) }, "chr NaN undef");
 321 like($@, qr/Cannot chr/, "NaN chr() fails");
 322 ok(!defined eval { $a = chr("NaN") }, "chr stringy NaN undef");
 323 like($@, qr/Cannot chr/, "stringy NaN chr() fails");
 324
 325 for my $f (@packi_fmt) {
 326     ok(!defined eval { $a = pack($f, $NaN) }, "pack $f NaN undef");
 327     like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
 328          "NaN pack $f fails");
 329     ok(!defined eval { $a = pack($f, "NaN") },
 330        "pack $f stringy NaN undef");
 331     like($@, $f eq 'w' ? qr/Cannot compress NaN/: qr/Cannot pack NaN/,
 332          "stringy NaN pack $f fails");
 333 }
 334
 335 for my $f (@packf_fmt) {
 336     ok(defined eval { $a = pack($f, $NaN) }, "pack $f NaN defined");
 337     eval { $b = unpack($f, $a) };
 338     cmp_ok($b, '!=', $b, "pack $f NaN not-equals $NaN");
 339 }
 340
 341 for my $f (@packs_fmt) {
 342     ok(defined eval { $a = pack($f, $NaN) }, "pack $f NaN defined");
 343     is($a, pack($f, "NaN"), "pack $f NaN same as 'NaN'");
 344 }
 345
 346 is eval { unpack "p", pack 'p', $NaN }, "NaN", "pack p +NaN";
 347 is eval { unpack "P3", pack 'P', $NaN }, "NaN", "pack P +NaN";
 348
 349 for my $i (@NaN) {
 350     cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
 351     is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
 352 }
 353
 354 ok(!($NaN <  0), "NaN is not lt zero");
 355 ok(!($NaN == 0), "NaN is not == zero");
 356 ok(!($NaN >  0), "NaN is not gt zero");
 357
 358 ok(!($NaN < $NaN), "NaN is not lt NaN");
 359 ok(!($NaN > $NaN), "NaN is not gt NaN");
 360
 361 # is() okay with $NaN because it uses eq.
 362 is($NaN * 0, $NaN, "NaN times zero is NaN");
 363 is($NaN * 2, $NaN, "NaN times two is NaN");
 364
 365 my ($NaNPP, $NaNMM) = ($NaN, $NaN);
 366 $NaNPP++;
 367 $NaNMM--;
 368 is($NaNPP, $NaN, "+NaN++ is NaN");
 369 is($NaNMM, $NaN, "+NaN-- is NaN");
 370
 371 # You might find this surprising (isn't NaN kind of like of undef?)
 372 # but this is how it is.
 373 ok($NaN, "NaN is true");
 374
 375 is(abs($NaN), $NaN, "abs(NaN) is NaN");
 376 is(int($NaN), $NaN, "int(NaN) is NaN");
 377 is(sqrt($NaN), $NaN, "sqrt(NaN) is NaN");
 378 is(exp($NaN), $NaN, "exp(NaN) is NaN");
 379
 380 SKIP: {
 381     if ($NaN == 0) {
 382         skip "if +NaN == 0 cannot log(+NaN)", 1;
 383     }
 384     is(log($NaN), $NaN, "log(NaN) is NaN");
 385 }
 386
 387 is(sin($NaN), $NaN, "sin(NaN) is NaN");
 388 is(rand($NaN), $NaN, "rand(NaN) is NaN");
 389
 390 TODO: {
 391     local $::TODO;
 392     my $here = "$^O $Config{osvers}";
 393     $::TODO = "$here: pow (9**9**9) doesn't give Inf"
 394         if $here =~ /^(?:hpux 10|os390)/;
 395     is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN");
 396 }
 397
 398 SKIP: {
 399     my @FNaN = qw(NaX XNAN Ind Inx);
 400     # Silence "isn't numeric in addition", that's kind of the point.
 401     local $^W = 0;
 402     for my $i (@FNaN) {
 403         cmp_ok("$i" + 0, '==', 0, "false nan $i");
 404     }
 405 }
 406
 407 {
 408     # Silence "Non-finite repeat count", that is tested elsewhere.
 409     local $^W = 0;
 410     is("a" x $NaN, "", "x NaN");
 411 }
 412
 413 # === Tests combining Inf and NaN ===
 414
 415 # is() okay with $NaN because it uses eq.
 416 is($PInf * 0,     $NaN, "Inf times zero is NaN");
 417 is($PInf * $NaN,  $NaN, "Inf times NaN is NaN");
 418 is($PInf + $NaN,  $NaN, "Inf plus NaN is NaN");
 419 is($PInf - $PInf, $NaN, "Inf minus inf is NaN");
 420 is($PInf / $PInf, $NaN, "Inf div inf is NaN");
 421 is($PInf % $PInf, $NaN, "Inf mod inf is NaN");
 422
 423 ok(!($NaN <  $PInf), "NaN is not lt +Inf");
 424 ok(!($NaN == $PInf), "NaN is not eq +Inf");
 425 ok(!($NaN >  $PInf), "NaN is not gt +Inf");
 426
 427 ok(!($NaN <  $NInf), "NaN is not lt -Inf");
 428 ok(!($NaN == $NInf), "NaN is not eq -Inf");
 429 ok(!($NaN >  $NInf), "NaN is not gt -Inf");
 430
 431 is(sin($PInf), $NaN, "sin(+Inf) is NaN");
 432
 433 {
 434     eval 'for my $x (0..$NaN) { last }';
 435     like($@, qr/Range iterator outside integer range/, "0..NaN fails");
 436
 437     eval 'for my $x ($NaN..0) { last }';
 438     like($@, qr/Range iterator outside integer range/, "NaN..0 fails");
 439 }
 440
 441 # === Overflows and Underflows ===
 442
 443 # 1e9999 (and 1e-9999) are large (and small) enough for even
 444 # IEEE quadruple precision (magnitude 10**4932, and 10**-4932).
 445
 446 cmp_ok(1e9999,     '==', $PInf, "overflow to +Inf (compile time)");
 447 cmp_ok('1e9999',   '==', $PInf, "overflow to +Inf (runtime)");
 448 cmp_ok(-1e9999,    '==', $NInf, "overflow to -Inf (compile time)");
 449 cmp_ok('-1e9999',  '==', $NInf, "overflow to -Inf (runtime)");
 450 cmp_ok(1e-9999,    '==', 0,     "underflow to 0 (compile time) from pos");
 451 cmp_ok('1e-9999',  '==', 0,     "underflow to 0 (runtime) from pos");
 452 cmp_ok(-1e-9999,   '==', 0,     "underflow to 0 (compile time) from neg");
 453 cmp_ok('-1e-9999', '==', 0,     "underflow to 0 (runtime) from neg");
 454
 455 # === Warnings triggered when and only when appropriate ===
 456 {
 457     my $w;
 458     local $SIG{__WARN__} = sub { $w = shift };
 459     local $^W = 1;
 460
 461     my $T =
 462         [
 463          [ "inf",          0, $PInf ],
 464          [ "infinity",     0, $PInf ],
 465          [ "infxy",        1, $PInf ],
 466          [ "inf34",        1, $PInf ],
 467          [ "1.#INF",       0, $PInf ],
 468          [ "1.#INFx",      1, $PInf ],
 469          [ "1.#INF00",     0, $PInf ],
 470          [ "1.#INFxy",     1, $PInf ],
 471          [ " inf",         0, $PInf ],
 472          [ "inf ",         0, $PInf ],
 473          [ " inf ",        0, $PInf ],
 474
 475          [ "nan",          0, $NaN ],
 476          [ "nanxy",        1, $NaN ],
 477          [ "nan34",        1, $NaN ],
 478          [ "nanq",         0, $NaN ],
 479          [ "nans",         0, $NaN ],
 480          [ "nanx",         1, $NaN ],
 481          [ "nanqy",        1, $NaN ],
 482          [ "nan(123)",     0, $NaN ],
 483          [ "nan(0x123)",   0, $NaN ],
 484          [ "nan(123xy)",   1, $NaN ],
 485          [ "nan(0x123xy)", 1, $NaN ],
 486          [ "nanq(123)",    0, $NaN ],
 487          [ "nan(123",      1, $NaN ],
 488          [ "nan(",         1, $NaN ],
 489          [ "1.#NANQ",      0, $NaN ],
 490          [ "1.#QNAN",      0, $NaN ],
 491          [ "1.#NANQx",     1, $NaN ],
 492          [ "1.#QNANx",     1, $NaN ],
 493          [ "1.#IND",       0, $NaN ],
 494          [ "1.#IND00",     0, $NaN ],
 495          [ "1.#INDxy",     1, $NaN ],
 496          [ " nan",         0, $NaN ],
 497          [ "nan ",         0, $NaN ],
 498          [ " nan ",        0, $NaN ],
 499         ];
 500
 501     for my $t (@$T) {
 502         print "# '$t->[0]' compile time\n";
 503         my $a;
 504         $w = '';
 505         eval '$a = "'.$t->[0].'" + 1';
 506         is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]");
 507         if ($t->[1]) {
 508             like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/,
 509                  "$t->[2] numify warn");
 510         } else {
 511             is($w, "", "no warning expected");
 512         }
 513         print "# '$t->[0]' runtime\n";
 514         my $n = $t->[0];
 515         my $b;
 516         $w = '';
 517         eval '$b = $n + 1';
 518         is("$b", "$t->[2]", "$n plus one is $t->[2]");
 519         if ($t->[1]) {
 520             like($w, qr/^Argument \Q"$n"\E isn't numeric/,
 521                  "$n numify warn");
 522         } else {
 523             is($w, "", "no warning expected");
 524         }
 525     }
 526 }
 527
 528 # === NaN quiet/signaling/payload ===
 529
 530 # The '#' or 'the alt' of printf knows how to prettyprint NaN payloads.
 531
 532 SKIP: {
 533     # Test only on certain known platforms since the features
 534     # are not that well standardized.
 535     unless (
 536          (
 537           $^O eq 'linux'
 538           ||
 539           $^O eq 'darwin' # OS X
 540           ||
 541           $^O eq 'freebsd'
 542          )
 543          &&
 544         (
 545          (
 546           $Config{nvsize} == 8 # double
 547           &&
 548           $Config{doublekind} == 3 # IEEE double little-endian (x86)
 549          )
 550          ||
 551          (
 552           $Config{nvsize} == 16 # double
 553           &&
 554           $Config{longdblkind} == 3 # x86 80-bit extended precision
 555          )
 556         )
 557         ||
 558         ($^O eq 'solaris'
 559          &&
 560          $Config{nvsize} == 8 && # double
 561          (
 562           $Config{uvsize} == 4 # 32-bit
 563           ||
 564           $Config{uvsize} == 8 # 64-bit (-Duse64bitint)
 565          ) &&
 566          $Config{doublesize} == 8 &&
 567          $Config{doublekind} == 4 # IEEE double big-endian (sparc)
 568         )
 569         ) {
 570         my ($uselongdouble, $longdblsize, $longdblkind) =
 571             $Config{uselongdouble} ?
 572             ($Config{uselongdouble},
 573              $Config{longdblsize},
 574              $Config{longdblkind}) :
 575             ('undef', 'undef', 'undef');
 576         skip("skipping NaN specials testing on os=$^O, uvsize=$Config{uvsize}, nvsize=$Config{nvsize}, doublekind=$Config{doublekind}, uselongdouble=$uselongdouble, longdblsize=$longdblsize, longdblkind=$longdblkind", 16);
 577     }
 578
 579     is(sprintf("%#g", $NaN), "NaN(0x0)", "sprintf %#g");
 580     is(sprintf("%#g", "nan"), "NaN(0x0)");
 581     is(sprintf("%#g", "nanq"), "NaN(0x0)");
 582     is(sprintf("%#g", "qnan"), "NaN(0x0)");
 583
 584     # This might look wrong but actually works as designed:
 585     # there cannot be a signaling nan with zero payload.
 586     # A signaling nan needs to have at least 0x1 as the payload.
 587     #
 588     # There can be a quiet nan with zero payload: this, in fact,
 589     # is usually the default "nan" of a platform.
 590     #
 591     # This weirdness brought to you courtesy of asymmetry in the IEEE spec.
 592     is(sprintf("%#g", "nans"), "Inf");
 593     is(sprintf("%#g", "snan"), "Inf");
 594
 595     is(sprintf("%#g", "nan(12345)"), "NaN(0x3039)");
 596     is(sprintf("%#g", "nan(0b101101)"), "NaN(0x2d)");
 597     is(sprintf("%#g", "nan(0x12345)"), "NaN(0x12345)");
 598     is(sprintf("%#g", "nanq(0x123EF)"), "NaN(0x123ef)");
 599     is(sprintf("%#g", "nans(0x12345)"), "NaNs(0x12345)");
 600     is(sprintf("%#g", "snan(0x12345)"), "NaNs(0x12345)");
 601
 602     is(sprintf("%#G", "nanq(0x123ef)"), "NaN(0X123EF)");
 603
 604   SKIP: {
 605       if (ord('A') == 65) { # ASCII
 606           is(sprintf("%#g", "nan('obot')"), "NaN(0x6f626f74)", "nanobot");
 607       } elsif (ord('A') == 193) { # EBCDIC
 608           is(sprintf("%#g", "nan('obot')"), "NaN(0x968296a3)", "nanobot");
 609       } else {
 610           skip "unknown encoding", 1;
 611     }
 612 }
 613
 614 }
 615
 616 done_testing();