t/op/hexfp.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 use strict;
  10
  11 use Config;
  12
  13 plan(tests => 123);
  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 is(0x.1p0, 0.0625);
  44 is(0x1.1p0, 1.0625);
  45 is(0x1.11p0, 1.06640625);
  46 is(0x1.111p0, 1.066650390625);
  47
  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
 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.
 114
 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
 124 # Needs to use within() instead of is() because of long doubles.
 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);
 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
 150     undef $a;
 151     eval '$a = eval "0x.3"';
 152     is($a, '03');
 153
 154     undef $a;
 155     eval '$a = eval "0xc.3"';
 156     is($a, '123');
 157
 158     undef $a;
 159     eval '$a = eval "0x.p3"';
 160     is($a, undef);
 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/);
 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);
 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);
 240     } else {
 241         print "# skipping warning tests\n";
 242         skip "nv_preserves_uv_bits is $Config{nv_preserves_uv_bits} not 53", 26;
 243     }
 244 }
 245
 246 # [perl #128919] limited exponent range in hex fp literal with long double
 247 SKIP: {
 248     skip("non-80-bit-long-double", 4)
 249         unless ($Config{uselongdouble} &&
 250                 ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
 251                 ($Config{long_double_style_ieee_extended}));
 252     is(0x1p-1074,  4.94065645841246544e-324);
 253     is(0x1p-1075,  2.47032822920623272e-324, '[perl #128919]');
 254     is(0x1p-1076,  1.23516411460311636e-324);
 255     is(0x1p-16445, 3.6451995318824746e-4951);
 256 }
 257
 258 # [perl #131894] parsing long binaryish floating point literals used to
 259 # perform illegal bit shifts
 260 SKIP: {
 261     skip("non-64-bit NVs", 1)
 262       unless $Config{nvsize} == 8 && $Config{d_double_style_ieee};
 263     is sprintf("%a", eval("0x030000000000000.1p0")), "0x1.8p+53";
 264     is sprintf("%a", eval("01400000000000000000.1p0")), "0x1.8p+54";
 265     is sprintf("%a", eval("0b110000000000000000000000000000000000000000000000000000000.1p0")), "0x1.8p+56";
 266 }
 267
 268 # the implementation also allow for octal and binary fp
 269 is(01p0, 1);
 270 is(01.0p0, 1);
 271 is(01.00p0, 1);
 272 is(010.1p0, 8.125);
 273 is(00.400p1, 1);
 274 is(00p0, 0);
 275 is(01.1p0, 1.125);
 276
 277 is(0b0p0, 0);
 278 is(0b1p0, 1);
 279 is(0b10p0, 2);
 280 is(0b1.1p0, 1.5);
 281
 282 # sprintf %a/%A testing is done in sprintf2.t,
 283 # trickier than necessary because of long doubles,
 284 # and because looseness of the spec.