| 1 | #!perl -w |
| 2 | |
| 3 | use strict; |
| 4 | |
| 5 | use POSIX ':math_h_c99'; |
| 6 | use POSIX ':nan_payload'; |
| 7 | use Test::More; |
| 8 | |
| 9 | use Config; |
| 10 | |
| 11 | # These tests are mainly to make sure that these arithmetic functions |
| 12 | # exist and are accessible. They are not meant to be an exhaustive |
| 13 | # test for the interface. |
| 14 | |
| 15 | sub between { |
| 16 | my ($low, $have, $high, $desc) = @_; |
| 17 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
| 18 | |
| 19 | cmp_ok($have, '>=', $low, $desc); |
| 20 | cmp_ok($have, '<=', $high, $desc); |
| 21 | } |
| 22 | |
| 23 | is(acos(1), 0, "Basic acos(1) test"); |
| 24 | between(3.14, acos(-1), 3.15, 'acos(-1)'); |
| 25 | between(1.57, acos(0), 1.58, 'acos(0)'); |
| 26 | is(asin(0), 0, "Basic asin(0) test"); |
| 27 | cmp_ok(asin(1), '>', 1.57, "Basic asin(1) test"); |
| 28 | cmp_ok(asin(-1), '<', -1.57, "Basic asin(-1) test"); |
| 29 | cmp_ok(asin(1), '==', -asin(-1), 'asin(1) == -asin(-1)'); |
| 30 | is(atan(0), 0, "Basic atan(0) test"); |
| 31 | between(0.785, atan(1), 0.786, 'atan(1)'); |
| 32 | between(-0.786, atan(-1), -0.785, 'atan(-1)'); |
| 33 | cmp_ok(atan(1), '==', -atan(-1), 'atan(1) == -atan(-1)'); |
| 34 | is(cosh(0), 1, "Basic cosh(0) test"); |
| 35 | between(1.54, cosh(1), 1.55, 'cosh(1)'); |
| 36 | between(1.54, cosh(-1), 1.55, 'cosh(-1)'); |
| 37 | is(cosh(1), cosh(-1), 'cosh(1) == cosh(-1)'); |
| 38 | is(floor(1.23441242), 1, "Basic floor(1.23441242) test"); |
| 39 | is(floor(-1.23441242), -2, "Basic floor(-1.23441242) test"); |
| 40 | is(fmod(3.5, 2.0), 1.5, "Basic fmod(3.5, 2.0) test"); |
| 41 | is(join(" ", frexp(1)), "0.5 1", "Basic frexp(1) test"); |
| 42 | is(ldexp(0,1), 0, "Basic ldexp(0,1) test"); |
| 43 | is(log10(1), 0, "Basic log10(1) test"); |
| 44 | is(log10(10), 1, "Basic log10(10) test"); |
| 45 | is(join(" ", modf(1.76)), "0.76 1", "Basic modf(1.76) test"); |
| 46 | is(sinh(0), 0, "Basic sinh(0) test"); |
| 47 | between(1.17, sinh(1), 1.18, 'sinh(1)'); |
| 48 | between(-1.18, sinh(-1), -1.17, 'sinh(-1)'); |
| 49 | is(tan(0), 0, "Basic tan(0) test"); |
| 50 | between(1.55, tan(1), 1.56, 'tan(1)'); |
| 51 | between(1.55, tan(1), 1.56, 'tan(-1)'); |
| 52 | cmp_ok(tan(1), '==', -tan(-1), 'tan(1) == -tan(-1)'); |
| 53 | is(tanh(0), 0, "Basic tanh(0) test"); |
| 54 | between(0.76, tanh(1), 0.77, 'tanh(1)'); |
| 55 | between(-0.77, tanh(-1), -0.76, 'tanh(-1)'); |
| 56 | cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)'); |
| 57 | |
| 58 | SKIP: { |
| 59 | skip "no fpclassify", 4 unless $Config{d_fpclassify}; |
| 60 | is(fpclassify(1), FP_NORMAL, "fpclassify 1"); |
| 61 | is(fpclassify(0), FP_ZERO, "fpclassify 0"); |
| 62 | is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); |
| 63 | is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); |
| 64 | } |
| 65 | |
| 66 | sub near { |
| 67 | my ($got, $want, $msg, $eps) = @_; |
| 68 | $eps ||= 1e-6; |
| 69 | cmp_ok(abs($got - $want), '<', $eps, $msg); |
| 70 | } |
| 71 | |
| 72 | SKIP: { |
| 73 | unless ($Config{d_acosh}) { |
| 74 | skip "no acosh, suspecting no C99 math"; |
| 75 | } |
| 76 | if ($^O =~ /Win32|VMS/) { |
| 77 | skip "running in $^O, C99 math support uneven"; |
| 78 | } |
| 79 | near(M_SQRT2, 1.4142135623731, "M_SQRT2", 1e-9); |
| 80 | near(M_E, 2.71828182845905, "M_E", 1e-9); |
| 81 | near(M_PI, 3.14159265358979, "M_PI", 1e-9); |
| 82 | near(acosh(2), 1.31695789692482, "acosh", 1e-9); |
| 83 | near(asinh(1), 0.881373587019543, "asinh", 1e-9); |
| 84 | near(atanh(0.5), 0.549306144334055, "atanh", 1e-9); |
| 85 | near(cbrt(8), 2, "cbrt", 1e-9); |
| 86 | near(cbrt(-27), -3, "cbrt", 1e-9); |
| 87 | near(copysign(3.14, -2), -3.14, "copysign", 1e-9); |
| 88 | near(expm1(2), 6.38905609893065, "expm1", 1e-9); |
| 89 | near(expm1(1e-6), 1.00000050000017e-06, "expm1", 1e-9); |
| 90 | is(fdim(12, 34), 0, "fdim 12 34"); |
| 91 | is(fdim(34, 12), 22, "fdim 34 12"); |
| 92 | is(fmax(12, 34), 34, "fmax 12 34"); |
| 93 | is(fmin(12, 34), 12, "fmin 12 34"); |
| 94 | is(hypot(3, 4), 5, "hypot 3 4"); |
| 95 | near(hypot(-2, 1), sqrt(5), "hypot -1 2", 1e-9); |
| 96 | is(ilogb(255), 7, "ilogb 255"); |
| 97 | is(ilogb(256), 8, "ilogb 256"); |
| 98 | ok(isfinite(1), "isfinite 1"); |
| 99 | ok(!isfinite(Inf), "isfinite Inf"); |
| 100 | ok(!isfinite(NaN), "isfinite NaN"); |
| 101 | ok(isinf(INFINITY), "isinf INFINITY"); |
| 102 | ok(isinf(Inf), "isinf Inf"); |
| 103 | ok(!isinf(NaN), "isinf NaN"); |
| 104 | ok(!isinf(42), "isinf 42"); |
| 105 | ok(isnan(NAN), "isnan NAN"); |
| 106 | ok(isnan(NaN), "isnan NaN"); |
| 107 | ok(!isnan(Inf), "isnan Inf"); |
| 108 | ok(!isnan(42), "isnan Inf"); |
| 109 | cmp_ok(nan(), '!=', nan(), 'nan'); |
| 110 | near(log1p(2), 1.09861228866811, "log1p", 1e-9); |
| 111 | near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9); |
| 112 | near(log2(8), 3, "log2", 1e-9); |
| 113 | is(signbit(2), 0, "signbit 2"); # zero |
| 114 | ok(signbit(-2), "signbit -2"); # non-zero |
| 115 | is(round(2.25), 2, "round 2.25"); |
| 116 | is(round(-2.25), -2, "round -2.25"); |
| 117 | is(round(2.5), 3, "round 2.5"); |
| 118 | is(round(-2.5), -3, "round -2.5"); |
| 119 | is(round(2.75), 3, "round 2.75"); |
| 120 | is(round(-2.75), -3, "round 2.75"); |
| 121 | is(trunc(2.25), 2, "trunc 2.25"); |
| 122 | is(trunc(-2.25), -2, "trunc -2.25"); |
| 123 | is(trunc(2.5), 2, "trunc 2.5"); |
| 124 | is(trunc(-2.5), -2, "trunc -2.5"); |
| 125 | is(trunc(2.75), 2, "trunc 2.75"); |
| 126 | is(trunc(-2.75), -2, "trunc -2.75"); |
| 127 | ok(isless(1, 2), "isless 1 2"); |
| 128 | ok(!isless(2, 1), "isless 2 1"); |
| 129 | ok(!isless(1, 1), "isless 1 1"); |
| 130 | ok(!isless(1, NaN), "isless 1 NaN"); |
| 131 | ok(isgreater(2, 1), "isgreater 2 1"); |
| 132 | ok(islessequal(1, 1), "islessequal 1 1"); |
| 133 | ok(isunordered(1, NaN), "isunordered 1 NaN"); |
| 134 | |
| 135 | near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7); |
| 136 | near(erf(1), 0.842700792949715, "erf 1", 1.5e-7); |
| 137 | near(erf(9), 1, "erf 9", 1.5e-7); |
| 138 | near(erfc(0.5), 0.479500122186953, "erfc 0.5", 1.5e-7); |
| 139 | near(erfc(1), 0.157299207050285, "erfc 1", 1.5e-7); |
| 140 | near(erfc(9), 0, "erfc 9", 1.5e-7); |
| 141 | |
| 142 | # tgamma(n) = (n - 1)! |
| 143 | # lgamma(n) = log(tgamma(n)) |
| 144 | near(tgamma(5), 24, "tgamma 5", 1.5e-7); |
| 145 | near(tgamma(5.5), 52.3427777845535, "tgamma 5.5", 1.5e-7); |
| 146 | near(tgamma(9), 40320, "tgamma 9", 1.5e-7); |
| 147 | near(lgamma(5), 3.17805383034795, "lgamma 4", 1.5e-7); |
| 148 | near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7); |
| 149 | near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7); |
| 150 | |
| 151 | # These don't work on old mips/hppa platforms because == Inf (or == -Inf). |
| 152 | # ok(isnan(setpayload(0)), "setpayload zero"); |
| 153 | # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)"); |
| 154 | # |
| 155 | # These don't work on most platforms because == Inf (or == -Inf). |
| 156 | # ok(isnan(setpayloadsig(0)), "setpayload zero"); |
| 157 | # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)"); |
| 158 | |
| 159 | # Verify that the payload set be setpayload() |
| 160 | # (1) still is a nan |
| 161 | # (2) but the payload can be retrieved |
| 162 | # (3) but is not signaling |
| 163 | my $x = 0; |
| 164 | setpayload($x, 0x12345); |
| 165 | ok(isnan($x), "setpayload + isnan"); |
| 166 | is(getpayload($x), 0x12345, "setpayload + getpayload"); |
| 167 | ok(!issignaling($x), "setpayload + issignaling"); |
| 168 | |
| 169 | # Verify that the signaling payload set be setpayloadsig() |
| 170 | # (1) still is a nan |
| 171 | # (2) but the payload can be retrieved |
| 172 | # (3) and is signaling |
| 173 | setpayloadsig($x, 0x12345); |
| 174 | ok(isnan($x), "setpayloadsig + isnan"); |
| 175 | is(getpayload($x), 0x12345, "setpayload + getpayload"); |
| 176 | ok(issignaling($x), "setpayloadsig + issignaling"); |
| 177 | |
| 178 | # Try a payload more than one byte. |
| 179 | is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload"); |
| 180 | |
| 181 | # Try payloads of 2^k, most importantly at and beyond 2^32. These |
| 182 | # tests will fail if NV is just 32-bit float, but that Should Not |
| 183 | # Happen (tm). |
| 184 | is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31"); |
| 185 | is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32"); |
| 186 | is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33"); |
| 187 | |
| 188 | # Payloads just lower than 2^k. |
| 189 | is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1"); |
| 190 | is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1"); |
| 191 | |
| 192 | # Payloads not divisible by two (and larger than 2**32). |
| 193 | |
| 194 | SKIP: { |
| 195 | # solaris gets 10460353202 from getpayload() when it should |
| 196 | # get 10460353203 (the 3**21). Things go wrong already in |
| 197 | # the nan() payload setting: [0x2, 0x6f7c52b4] (ivsize=4) |
| 198 | # instead [0x2, 0x6f7c52b3]. Then at getpayload() things |
| 199 | # go wrong again, now in other direction: with the (wrong) |
| 200 | # [0x2, 0x6f7c52b4] encoded in the nan we should decode into |
| 201 | # 10460353204, but we get 10460353202. It doesn't seem to |
| 202 | # help even if we use 'unsigned long long' instead of UV/U32 |
| 203 | # in the POSIX.xs:S_setpayload/S_getpayload. |
| 204 | # |
| 205 | # casting bug? fmod() bug? Though also broken with |
| 206 | # -Duselongdouble + fmodl(), so maybe Solaris cc bug |
| 207 | # in general? |
| 208 | # |
| 209 | # Ironically, the large prime seems to work even in Solaris, |
| 210 | # probably just by blind luck. |
| 211 | skip($^O, 1) if $^O eq 'solaris'; |
| 212 | is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21"); |
| 213 | } |
| 214 | is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime"); |
| 215 | |
| 216 | # Truncates towards zero. |
| 217 | is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload"); |
| 218 | |
| 219 | # Not signaling. |
| 220 | ok(!issignaling(0), "issignaling zero"); |
| 221 | ok(!issignaling(+Inf), "issignaling +Inf"); |
| 222 | ok(!issignaling(-Inf), "issignaling -Inf"); |
| 223 | ok(!issignaling(NaN), "issignaling NaN"); |
| 224 | } # SKIP |
| 225 | |
| 226 | done_testing(); |