1#!perl -w 2 3use strict; 4 5use POSIX ':math_h_c99'; 6use POSIX ':nan_payload'; 7use Test::More; 8 9use 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 15sub 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 23is(acos(1), 0, "Basic acos(1) test"); 24between(3.14, acos(-1), 3.15, 'acos(-1)'); 25between(1.57, acos(0), 1.58, 'acos(0)'); 26is(asin(0), 0, "Basic asin(0) test"); 27cmp_ok(asin(1), '>', 1.57, "Basic asin(1) test"); 28cmp_ok(asin(-1), '<', -1.57, "Basic asin(-1) test"); 29cmp_ok(asin(1), '==', -asin(-1), 'asin(1) == -asin(-1)'); 30is(atan(0), 0, "Basic atan(0) test"); 31between(0.785, atan(1), 0.786, 'atan(1)'); 32between(-0.786, atan(-1), -0.785, 'atan(-1)'); 33cmp_ok(atan(1), '==', -atan(-1), 'atan(1) == -atan(-1)'); 34is(cosh(0), 1, "Basic cosh(0) test"); 35between(1.54, cosh(1), 1.55, 'cosh(1)'); 36between(1.54, cosh(-1), 1.55, 'cosh(-1)'); 37is(cosh(1), cosh(-1), 'cosh(1) == cosh(-1)'); 38is(floor(1.23441242), 1, "Basic floor(1.23441242) test"); 39is(floor(-1.23441242), -2, "Basic floor(-1.23441242) test"); 40is(fmod(3.5, 2.0), 1.5, "Basic fmod(3.5, 2.0) test"); 41is(join(" ", frexp(1)), "0.5 1", "Basic frexp(1) test"); 42is(ldexp(0,1), 0, "Basic ldexp(0,1) test"); 43is(log10(1), 0, "Basic log10(1) test"); 44is(log10(10), 1, "Basic log10(10) test"); 45is(join(" ", modf(1.76)), "0.76 1", "Basic modf(1.76) test"); 46is(sinh(0), 0, "Basic sinh(0) test"); 47between(1.17, sinh(1), 1.18, 'sinh(1)'); 48between(-1.18, sinh(-1), -1.17, 'sinh(-1)'); 49is(tan(0), 0, "Basic tan(0) test"); 50between(1.55, tan(1), 1.56, 'tan(1)'); 51between(1.55, tan(1), 1.56, 'tan(-1)'); 52cmp_ok(tan(1), '==', -tan(-1), 'tan(1) == -tan(-1)'); 53is(tanh(0), 0, "Basic tanh(0) test"); 54between(0.76, tanh(1), 0.77, 'tanh(1)'); 55between(-0.77, tanh(-1), -0.76, 'tanh(-1)'); 56cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)'); 57 58SKIP: { 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 SKIP: { 63 skip("no inf", 1) unless $Config{d_double_has_inf}; 64 is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); 65 } 66 SKIP: { 67 skip("no nan", 1) unless $Config{d_double_has_nan}; 68 is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); 69 } 70} 71 72sub near { 73 my ($got, $want, $msg, $eps) = @_; 74 $eps ||= 1e-6; 75 cmp_ok(abs($got - $want), '<', $eps, $msg); 76} 77 78SKIP: { 79 80 unless ($Config{d_acosh}) { 81 skip "no acosh, suspecting no C99 math"; 82 } 83 if ($^O =~ /VMS/) { 84 skip "running in $^O, C99 math support uneven"; 85 } 86 87 near(M_SQRT2, 1.4142135623731, "M_SQRT2", 1e-9); 88 near(M_E, 2.71828182845905, "M_E", 1e-9); 89 near(M_PI, 3.14159265358979, "M_PI", 1e-9); 90 near(acosh(2), 1.31695789692482, "acosh", 1e-9); 91 near(asinh(1), 0.881373587019543, "asinh", 1e-9); 92 near(atanh(0.5), 0.549306144334055, "atanh", 1e-9); 93 near(cbrt(8), 2, "cbrt", 1e-9); 94 near(cbrt(-27), -3, "cbrt", 1e-9); 95 near(copysign(3.14, -2), -3.14, "copysign", 1e-9); 96 near(expm1(2), 6.38905609893065, "expm1", 1e-9); 97 near(expm1(1e-6), 1.00000050000017e-06, "expm1", 1e-9); 98 is(fdim(12, 34), 0, "fdim 12 34"); 99 is(fdim(34, 12), 22, "fdim 34 12"); 100 is(fmax(12, 34), 34, "fmax 12 34"); 101 is(fmin(12, 34), 12, "fmin 12 34"); 102 is(hypot(3, 4), 5, "hypot 3 4"); 103 near(hypot(-2, 1), sqrt(5), "hypot -1 2", 1e-9); 104 is(ilogb(255), 7, "ilogb 255"); 105 is(ilogb(256), 8, "ilogb 256"); 106 ok(isfinite(1), "isfinite 1"); 107 ok(!isinf(42), "isinf 42"); 108 ok(!isnan(42), "isnan Inf"); 109 SKIP: { 110 skip("no inf", 3) unless $Config{d_double_has_inf}; 111 ok(!isfinite(Inf), "isfinite Inf"); 112 ok(isinf(Inf), "isinf Inf"); 113 ok(!isnan(Inf), "isnan Inf"); 114 } 115 SKIP: { 116 skip("no nan", 4) unless $Config{d_double_has_nan}; 117 ok(!isfinite(NaN), "isfinite NaN"); 118 ok(!isinf(NaN), "isinf NaN"); 119 ok(isnan(NaN), "isnan NaN"); 120 cmp_ok(nan(), '!=', nan(), 'nan'); 121 } 122 near(log1p(2), 1.09861228866811, "log1p", 1e-9); 123 near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9); 124 near(log2(8), 3, "log2", 1e-9); 125 is(signbit(2), 0, "signbit 2"); # zero 126 ok(signbit(-2), "signbit -2"); # non-zero 127 is(signbit(0), 0, "signbit 0"); # zero 128 is(signbit(0.5), 0, "signbit 0.5"); # zero 129 ok(signbit(-0.5), "signbit -0.5"); # non-zero 130 is(round(2.25), 2, "round 2.25"); 131 is(round(-2.25), -2, "round -2.25"); 132 is(round(2.5), 3, "round 2.5"); 133 is(round(-2.5), -3, "round -2.5"); 134 is(round(2.75), 3, "round 2.75"); 135 is(round(-2.75), -3, "round 2.75"); 136 is(lround(-2.75), -3, "lround -2.75"); 137 is(lround(-0.25), 0, "lround -0.25"); 138 is(lround(-0.50), -1, "lround -0.50"); 139 is(signbit(lround(-0.25)), 0, "signbit lround -0.25 zero"); 140 ok(signbit(lround(-0.50)), "signbit lround -0.50 non-zero"); # non-zero 141 is(trunc(2.25), 2, "trunc 2.25"); 142 is(trunc(-2.25), -2, "trunc -2.25"); 143 is(trunc(2.5), 2, "trunc 2.5"); 144 is(trunc(-2.5), -2, "trunc -2.5"); 145 is(trunc(2.75), 2, "trunc 2.75"); 146 is(trunc(-2.75), -2, "trunc -2.75"); 147 ok(isless(1, 2), "isless 1 2"); 148 ok(!isless(2, 1), "isless 2 1"); 149 ok(!isless(1, 1), "isless 1 1"); 150 ok(isgreater(2, 1), "isgreater 2 1"); 151 ok(islessequal(1, 1), "islessequal 1 1"); 152 153 SKIP: { 154 skip("no nan", 2) unless $Config{d_double_has_nan}; 155 ok(!isless(1, NaN), "isless 1 NaN"); 156 ok(isunordered(1, NaN), "isunordered 1 NaN"); 157 } 158 159 near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7); 160 near(erf(1), 0.842700792949715, "erf 1", 1.5e-7); 161 near(erf(9), 1, "erf 9", 1.5e-7); 162 near(erfc(0.5), 0.479500122186953, "erfc 0.5", 1.5e-7); 163 near(erfc(1), 0.157299207050285, "erfc 1", 1.5e-7); 164 near(erfc(9), 0, "erfc 9", 1.5e-7); 165 166 # tgamma(n) = (n - 1)! 167 # lgamma(n) = log(tgamma(n)) 168 near(tgamma(5), 24, "tgamma 5", 1.5e-7); 169 near(tgamma(5.5), 52.3427777845535, "tgamma 5.5", 1.5e-7); 170 near(tgamma(9), 40320, "tgamma 9", 1.5e-7); 171 near(lgamma(5), 3.17805383034795, "lgamma 4", 1.5e-7); 172 near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7); 173 near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7); 174 175 SKIP: { 176 skip("no inf/nan", 19) unless $Config{d_double_has_inf} && $Config{d_double_has_nan}; 177 178 # These don't work on old mips/hppa platforms 179 # because nan with payload zero == Inf (or == -Inf). 180 # ok(isnan(setpayload(0)), "setpayload zero"); 181 # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)"); 182 # 183 # These don't work on most platforms because == Inf (or == -Inf). 184 # ok(isnan(setpayloadsig(0)), "setpayload zero"); 185 # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)"); 186 187 # Verify that the payload set be setpayload() 188 # (1) still is a nan 189 # (2) but the payload can be retrieved 190 # (3) but is not signaling 191 my $x = 0; 192 setpayload($x, 0x12345); 193 ok(isnan($x), "setpayload + isnan"); 194 is(getpayload($x), 0x12345, "setpayload + getpayload"); 195 ok(!issignaling($x), "setpayload + issignaling"); 196 197 # Verify that the signaling payload set be setpayloadsig() 198 # (1) still is a nan 199 # (2) but the payload can be retrieved 200 # (3) and is signaling 201 setpayloadsig($x, 0x12345); 202 ok(isnan($x), "setpayloadsig + isnan"); 203 is(getpayload($x), 0x12345, "setpayloadsig + getpayload"); 204 SKIP: { 205 # https://rt.perl.org/Ticket/Display.html?id=125710 206 # In the 32-bit x86 ABI cannot preserve the signaling bit 207 # (the x87 simply does not preserve that). But using the 208 # 80-bit extended format aka long double, the bit is preserved. 209 # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484 210 my $could_be_x86_32 = 211 # This is a really weak test: there are other 32-bit 212 # little-endian platforms than just Intel (some embedded 213 # processors, for example), but we use this just for not 214 # bothering with the test if things look iffy. 215 # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/, 216 # but that feels quite shaky. 217 $Config{byteorder} =~ /1234/ && 218 $Config{longdblkind} == 3 && 219 $Config{ptrsize} == 4; 220 skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble}; 221 ok(issignaling($x), "setpayloadsig + issignaling"); 222 } 223 224 # Try a payload more than one byte. 225 is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload"); 226 227 # Try payloads of 2^k, most importantly at and beyond 2^32. These 228 # tests will fail if NV is just 32-bit float, but that Should Not 229 # Happen (tm). 230 is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31"); 231 is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32"); 232 is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33"); 233 234 # Payloads just lower than 2^k. 235 is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1"); 236 is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1"); 237 238 # Payloads not divisible by two (and larger than 2**32). 239 240 SKIP: { 241 # solaris gets 10460353202 from getpayload() when it should 242 # get 10460353203 (the 3**21). Things go wrong already in 243 # the nan() payload setting: [0x2, 0x6f7c52b4] (ivsize=4) 244 # instead [0x2, 0x6f7c52b3]. Then at getpayload() things 245 # go wrong again, now in other direction: with the (wrong) 246 # [0x2, 0x6f7c52b4] encoded in the nan we should decode into 247 # 10460353204, but we get 10460353202. It doesn't seem to 248 # help even if we use 'unsigned long long' instead of UV/U32 249 # in the POSIX.xs:S_setpayload/S_getpayload. 250 # 251 # casting bug? fmod() bug? Though also broken with 252 # -Duselongdouble + fmodl(), so maybe Solaris cc bug 253 # in general? 254 # 255 # Ironically, the large prime seems to work even in Solaris, 256 # probably just by blind luck. 257 skip($^O, 1) if $^O eq 'solaris'; 258 is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21"); 259 } 260 is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime"); 261 262 # Truncates towards zero. 263 is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload"); 264 265 # Not signaling. 266 ok(!issignaling(0), "issignaling zero"); 267 ok(!issignaling(+Inf), "issignaling +Inf"); 268 ok(!issignaling(-Inf), "issignaling -Inf"); 269 ok(!issignaling(NaN), "issignaling NaN"); 270 } 271} # SKIP 272 273SKIP: { 274 skip('no INFINITY', 4) unless defined &INFINITY; 275 # Note that if INFINITY were a bareword, it would be numified to +Inf, 276 # which might confuse following tests. 277 # But this cannot happen as long as "use strict" is effective. 278 ok(isinf(INFINITY), "isinf INFINITY"); 279 is(INFINITY, 'Inf', "INFINITY is Perl's Inf"); 280 cmp_ok(INFINITY, '>', ($Config{uselongdouble} ? POSIX::LDBL_MAX : POSIX::DBL_MAX), 281 "INFINITY > DBL_MAX"); 282 ok(!signbit(INFINITY), "signbit(INFINITY)"); 283} 284 285SKIP: { 286 skip('no NAN', 5) unless defined &NAN; 287 ok(isnan(NAN()), "isnan NAN"); 288 # Using like() rather than is() is to deal with non-zero payload 289 # (currently this is not the case, but someday Perl might stringify it...) 290 like(NAN, qr/^NaN/, "NAN is Perl's NaN"); 291 cmp_ok(NAN, '!=', NAN, "NAN != NAN"); 292 ok(!(NAN == NAN), "NAN == NAN"); 293 # we have a fallback copysign(), but it doesn't work for NaN 294 skip('no copysign', 2) unless $Config{d_copysign}; 295 ok(!signbit(copysign(NAN, 1.0)), "signbit(copysign(NAN, 1.0)))"); 296 ok(signbit(copysign(NAN, -1.0)), "signbit(copysign(NAN, -1.0)))"); 297} 298 299done_testing(); 300