Commit | Line | Data |
---|---|---|
61e61fbc JH |
1 | #!./perl |
2 | ||
61e61fbc JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
9224f6d1 | 5 | @INC = '../lib'; |
61e61fbc | 6 | require './test.pl'; |
61e61fbc JH |
7 | } |
8 | ||
0b1b7115 JH |
9 | use strict; |
10 | ||
11 | use Config; | |
12 | ||
eba98284 | 13 | plan(tests => 105); |
61e61fbc JH |
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 | ||
eba98284 JH |
43 | is(0x.1p0, 0.0625); |
44 | is(0x1.1p0, 1.0625); | |
45 | is(0x1.11p0, 1.06640625); | |
46 | is(0x1.111p0, 1.066650390625); | |
47 | ||
61e61fbc JH |
48 | # Positive exponents. |
49 | is(0x1p2, 4); | |
50 | is(0x1p+2, 4); | |
51 | is(0x0p+0, 0); | |
52 | ||
53 | # Negative exponents. | |
54 | is(0x1p-1, 0.5); | |
55 | is(0x1.p-1, 0.5); | |
56 | is(0x1.0p-1, 0.5); | |
57 | is(0x0p-0, 0); | |
58 | ||
59 | is(0x1p+2, 4); | |
60 | is(0x1p-2, 0.25); | |
61 | ||
62 | is(0x3p+2, 12); | |
63 | is(0x3p-2, 0.75); | |
64 | ||
65 | # Shifting left. | |
66 | is(0x1p2, 1 << 2); | |
67 | is(0x1p3, 1 << 3); | |
68 | is(0x3p4, 3 << 4); | |
69 | is(0x3p5, 3 << 5); | |
70 | is(0x12p23, 0x12 << 23); | |
71 | ||
72 | # Shifting right. | |
73 | is(0x1p-2, 1 / (1 << 2)); | |
74 | is(0x1p-3, 1 / (1 << 3)); | |
75 | is(0x3p-4, 3 / (1 << 4)); | |
76 | is(0x3p-5, 3 / (1 << 5)); | |
77 | is(0x12p-23, 0x12 / (1 << 23)); | |
78 | ||
79 | # Negative sign. | |
80 | is(-0x1p+2, -4); | |
81 | is(-0x1p-2, -0.25); | |
82 | is(-0x0p+0, 0); | |
83 | is(-0x0p-0, 0); | |
84 | ||
85 | is(0x0.10p0, 0.0625); | |
86 | is(0x0.1p0, 0.0625); | |
87 | is(0x.1p0, 0.0625); | |
88 | ||
89 | is(0x12p+3, 144); | |
90 | is(0x12p-3, 2.25); | |
91 | ||
92 | # Hexdigits (lowercase). | |
93 | is(0x9p+0, 9); | |
94 | is(0xap+0, 10); | |
95 | is(0xfp+0, 15); | |
96 | is(0x10p+0, 16); | |
97 | is(0x11p+0, 17); | |
98 | is(0xabp+0, 171); | |
99 | is(0xab.cdp+0, 171.80078125); | |
100 | ||
101 | # Uppercase hexdigits and exponent prefix. | |
102 | is(0xAp+0, 10); | |
103 | is(0xFp+0, 15); | |
104 | is(0xABP+0, 171); | |
105 | is(0xAB.CDP+0, 171.80078125); | |
106 | ||
107 | # Underbars. | |
108 | is(0xa_b.c_dp+1_2, 703696); | |
109 | ||
6c69a4c9 JH |
110 | # Note that the hexfloat representation is not unique since the |
111 | # exponent can be shifted, and the hexdigits with it: this is no | |
112 | # different from 3e4 cf 30e3 cf 30000. The shifting of the hexdigits | |
113 | # makes it look stranger, though: 0xap1 == 0x5p2. | |
61e61fbc | 114 | |
eba98284 JH |
115 | # [perl #127183], try some non-canonical forms. |
116 | SKIP: { | |
117 | skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits} not 53", 3) | |
118 | unless ($Config{nv_preserves_uv_bits} == 53); | |
119 | is(0x0.b17217f7d1cf78p0, 0x1.62e42fefa39efp-1); | |
120 | is(0x0.58b90bfbe8e7bcp1, 0x1.62e42fefa39efp-1); | |
121 | is(0x0.2c5c85fdf473dep2, 0x1.62e42fefa39efp-1); | |
122 | } | |
123 | ||
61e61fbc | 124 | # Needs to use within() instead of is() because of long doubles. |
6c69a4c9 JH |
125 | within(0x1.99999999999ap-4, 0.1, 1e-9); |
126 | within(0x3.333333333333p-5, 0.1, 1e-9); | |
127 | within(0xc.cccccccccccdp-7, 0.1, 1e-9); | |
61e61fbc JH |
128 | |
129 | my $warn; | |
130 | ||
131 | local $SIG{__WARN__} = sub { $warn = shift }; | |
132 | ||
133 | sub get_warn() { | |
134 | my $save = $warn; | |
135 | undef $warn; | |
136 | return $save; | |
137 | } | |
138 | ||
139 | { # Test certain things that are not hexfloats and should stay that way. | |
140 | eval '0xp3'; | |
141 | like(get_warn(), qr/Missing operator before p3/); | |
142 | ||
143 | eval '5p3'; | |
144 | like(get_warn(), qr/Missing operator before p3/); | |
145 | ||
146 | my @a; | |
147 | eval '@a = 0x3..5'; | |
148 | is("@a", "3 4 5"); | |
149 | ||
eba98284 | 150 | undef $a; |
61e61fbc JH |
151 | eval '$a = eval "0x.3"'; |
152 | is($a, '03'); | |
153 | ||
eba98284 | 154 | undef $a; |
61e61fbc JH |
155 | eval '$a = eval "0xc.3"'; |
156 | is($a, '123'); | |
eba98284 JH |
157 | |
158 | undef $a; | |
159 | eval '$a = eval "0x.p3"'; | |
160 | is($a, undef); | |
61e61fbc JH |
161 | } |
162 | ||
163 | # Test warnings. | |
164 | SKIP: | |
165 | { | |
166 | if ($Config{nv_preserves_uv_bits} == 53) { | |
167 | local $^W = 1; | |
168 | ||
169 | eval '0x1_0000_0000_0000_0p0'; | |
170 | is(get_warn(), undef); | |
171 | ||
172 | eval '0x2_0000_0000_0000_0p0'; | |
173 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
174 | ||
175 | eval '0x1.0000_0000_0000_0p0'; | |
176 | is(get_warn(), undef); | |
177 | ||
178 | eval '0x2.0000_0000_0000_0p0'; | |
179 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
180 | ||
181 | eval '0x.1p-1021'; | |
182 | is(get_warn(), undef); | |
183 | ||
184 | eval '0x.1p-1023'; | |
185 | like(get_warn(), qr/^Hexadecimal float: exponent underflow/); | |
186 | ||
187 | eval '0x1.fffffffffffffp+1023'; | |
188 | is(get_warn(), undef); | |
189 | ||
190 | eval '0x1.fffffffffffffp+1024'; | |
191 | like(get_warn(), qr/^Hexadecimal float: exponent overflow/); | |
0c8adad7 JH |
192 | |
193 | undef $a; | |
194 | eval '$a = 0x111.0000000000000p+0'; # 12 zeros. | |
195 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
196 | is($a, 273); | |
197 | ||
198 | # The 13 zeros would be enough to push the hi-order digits | |
199 | # off the high-end. | |
200 | ||
201 | undef $a; | |
202 | eval '$a = 0x111.0000000000000p+0'; # 13 zeros. | |
203 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
204 | is($a, 273); | |
205 | ||
206 | undef $a; | |
207 | eval '$a = 0x111.00000000000000p+0'; # 14 zeros. | |
208 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
209 | is($a, 273); | |
96524c28 JH |
210 | |
211 | undef $a; | |
212 | eval '$a = 0xfffffffffffffp0'; # 52 bits. | |
213 | is(get_warn(), undef); | |
214 | is($a, 4.5035996273705e+15); | |
215 | ||
216 | undef $a; | |
217 | eval '$a = 0xfffffffffffff.8p0'; # 53 bits. | |
218 | is(get_warn(), undef); | |
219 | is($a, 4.5035996273705e+15); | |
220 | ||
221 | undef $a; | |
222 | eval '$a = 0xfffffffffffff.cp0'; # 54 bits. | |
223 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
224 | is($a, 4.5035996273705e+15); | |
225 | ||
226 | undef $a; | |
227 | eval '$a = 0xf.ffffffffffffp0'; # 52 bits. | |
228 | is(get_warn(), undef); | |
229 | is($a, 16); | |
230 | ||
231 | undef $a; | |
232 | eval '$a = 0xf.ffffffffffff8p0'; # 53 bits. | |
233 | is(get_warn(), undef); | |
234 | is($a, 16); | |
235 | ||
236 | undef $a; | |
237 | eval '$a = 0xf.ffffffffffffcp0'; # 54 bits. | |
238 | like(get_warn(), qr/^Hexadecimal float: mantissa overflow/); | |
239 | is($a, 16); | |
61e61fbc JH |
240 | } else { |
241 | print "# skipping warning tests\n"; | |
96524c28 | 242 | skip "nv_preserves_uv_bits is $Config{nv_preserves_uv_bits} not 53", 26; |
61e61fbc JH |
243 | } |
244 | } | |
245 | ||
246 | # sprintf %a/%A testing is done in sprintf2.t, | |
247 | # trickier than necessary because of long doubles, | |
248 | # and because looseness of the spec. |