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