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 => 79);
  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     } else {
 173         print "# skipping warning tests\n";
 174         skip "nv_preserves_uv_bits is $Config{nv_preserves_uv_bits} not 53", 8;
 175     }
 176 }
 177
 178 # sprintf %a/%A testing is done in sprintf2.t,
 179 # trickier than necessary because of long doubles,
 180 # and because looseness of the spec.