This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix a race condition in parallel builds with Visual C
[perl5.git] / t / op / hexfp.t
1 #!./perl
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 plan(tests => 97);
14
15 # Test hexfloat literals.
16
17 is(0x0p0, 0);
18 is(0x0.p0, 0);
19 is(0x.0p0, 0);
20 is(0x0.0p0, 0);
21 is(0x0.00p0, 0);
22
23 is(0x1p0, 1);
24 is(0x1.p0, 1);
25 is(0x1.0p0, 1);
26 is(0x1.00p0, 1);
27
28 is(0x2p0, 2);
29 is(0x2.p0, 2);
30 is(0x2.0p0, 2);
31 is(0x2.00p0, 2);
32
33 is(0x1p1, 2);
34 is(0x1.p1, 2);
35 is(0x1.0p1, 2);
36 is(0x1.00p1, 2);
37
38 is(0x.1p0, 0.0625);
39 is(0x0.1p0, 0.0625);
40 is(0x0.10p0, 0.0625);
41 is(0x0.100p0, 0.0625);
42
43 # Positive exponents.
44 is(0x1p2, 4);
45 is(0x1p+2, 4);
46 is(0x0p+0, 0);
47
48 # Negative exponents.
49 is(0x1p-1, 0.5);
50 is(0x1.p-1, 0.5);
51 is(0x1.0p-1, 0.5);
52 is(0x0p-0, 0);
53
54 is(0x1p+2, 4);
55 is(0x1p-2, 0.25);
56
57 is(0x3p+2, 12);
58 is(0x3p-2, 0.75);
59
60 # Shifting left.
61 is(0x1p2, 1 << 2);
62 is(0x1p3, 1 << 3);
63 is(0x3p4, 3 << 4);
64 is(0x3p5, 3 << 5);
65 is(0x12p23, 0x12 << 23);
66
67 # Shifting right.
68 is(0x1p-2, 1 / (1 << 2));
69 is(0x1p-3, 1 / (1 << 3));
70 is(0x3p-4, 3 / (1 << 4));
71 is(0x3p-5, 3 / (1 << 5));
72 is(0x12p-23, 0x12 / (1 << 23));
73
74 # Negative sign.
75 is(-0x1p+2, -4);
76 is(-0x1p-2, -0.25);
77 is(-0x0p+0, 0);
78 is(-0x0p-0, 0);
79
80 is(0x0.10p0, 0.0625);
81 is(0x0.1p0, 0.0625);
82 is(0x.1p0, 0.0625);
83
84 is(0x12p+3, 144);
85 is(0x12p-3, 2.25);
86
87 # Hexdigits (lowercase).
88 is(0x9p+0, 9);
89 is(0xap+0, 10);
90 is(0xfp+0, 15);
91 is(0x10p+0, 16);
92 is(0x11p+0, 17);
93 is(0xabp+0, 171);
94 is(0xab.cdp+0, 171.80078125);
95
96 # Uppercase hexdigits and exponent prefix.
97 is(0xAp+0, 10);
98 is(0xFp+0, 15);
99 is(0xABP+0, 171);
100 is(0xAB.CDP+0, 171.80078125);
101
102 # Underbars.
103 is(0xa_b.c_dp+1_2, 703696);
104
105 # Note that the hexfloat representation is not unique since the
106 # exponent can be shifted, and the hexdigits with it: this is no
107 # different from 3e4 cf 30e3 cf 30000.  The shifting of the hexdigits
108 # makes it look stranger, though: 0xap1 == 0x5p2.
109
110 # Needs to use within() instead of is() because of long doubles.
111 within(0x1.99999999999ap-4, 0.1, 1e-9);
112 within(0x3.333333333333p-5, 0.1, 1e-9);
113 within(0xc.cccccccccccdp-7, 0.1, 1e-9);
114
115 my $warn;
116
117 local $SIG{__WARN__} = sub { $warn = shift };
118
119 sub get_warn() {
120     my $save = $warn;
121     undef $warn;
122     return $save;
123 }
124
125 { # Test certain things that are not hexfloats and should stay that way.
126     eval '0xp3';
127     like(get_warn(), qr/Missing operator before p3/);
128
129     eval '5p3';
130     like(get_warn(), qr/Missing operator before p3/);
131
132     my @a;
133     eval '@a = 0x3..5';
134     is("@a", "3 4 5");
135
136     eval '$a = eval "0x.3"';
137     is($a, '03');
138
139     eval '$a = eval "0xc.3"';
140     is($a, '123');
141 }
142
143 # Test warnings.
144 SKIP:
145 {
146     if ($Config{nv_preserves_uv_bits} == 53) {
147         local $^W = 1;
148
149         eval '0x1_0000_0000_0000_0p0';
150         is(get_warn(), undef);
151
152         eval '0x2_0000_0000_0000_0p0';
153         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
154
155         eval '0x1.0000_0000_0000_0p0';
156         is(get_warn(), undef);
157
158         eval '0x2.0000_0000_0000_0p0';
159         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
160
161         eval '0x.1p-1021';
162         is(get_warn(), undef);
163
164         eval '0x.1p-1023';
165         like(get_warn(), qr/^Hexadecimal float: exponent underflow/);
166
167         eval '0x1.fffffffffffffp+1023';
168         is(get_warn(), undef);
169
170         eval '0x1.fffffffffffffp+1024';
171         like(get_warn(), qr/^Hexadecimal float: exponent overflow/);
172
173         undef $a;
174         eval '$a = 0x111.0000000000000p+0'; # 12 zeros.
175         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
176         is($a, 273);
177
178         # The 13 zeros would be enough to push the hi-order digits
179         # off the high-end.
180
181         undef $a;
182         eval '$a = 0x111.0000000000000p+0'; # 13 zeros.
183         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
184         is($a, 273);
185
186         undef $a;
187         eval '$a = 0x111.00000000000000p+0';  # 14 zeros.
188         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
189         is($a, 273);
190
191         undef $a;
192         eval '$a = 0xfffffffffffffp0';  # 52 bits.
193         is(get_warn(), undef);
194         is($a, 4.5035996273705e+15);
195
196         undef $a;
197         eval '$a = 0xfffffffffffff.8p0';  # 53 bits.
198         is(get_warn(), undef);
199         is($a, 4.5035996273705e+15);
200
201         undef $a;
202         eval '$a = 0xfffffffffffff.cp0';  # 54 bits.
203         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
204         is($a, 4.5035996273705e+15);
205
206         undef $a;
207         eval '$a = 0xf.ffffffffffffp0';  # 52 bits.
208         is(get_warn(), undef);
209         is($a, 16);
210
211         undef $a;
212         eval '$a = 0xf.ffffffffffff8p0';  # 53 bits.
213         is(get_warn(), undef);
214         is($a, 16);
215
216         undef $a;
217         eval '$a = 0xf.ffffffffffffcp0';  # 54 bits.
218         like(get_warn(), qr/^Hexadecimal float: mantissa overflow/);
219         is($a, 16);
220     } else {
221         print "# skipping warning tests\n";
222         skip "nv_preserves_uv_bits is $Config{nv_preserves_uv_bits} not 53", 26;
223     }
224 }
225
226 # sprintf %a/%A testing is done in sprintf2.t,
227 # trickier than necessary because of long doubles,
228 # and because looseness of the spec.