Hexadecimal float sprintf, for perl #122219

Do not use the system sprintf since %a/%A is C99 (which we do not
require), and even if we did, there is room for interpretation
(for example whether to print trailing zeros or not) which means
that existing implementations will inevitably differ.

For the most common case, 64-bit doubles of IEEE 754, use first
frexp to extract the exponent, and then ldexp to scale the result
to a 64-bit unsigned integer.

For long doubles (80-bit or 128-bit) we look directly at the mantissa
(also known as fraction, or significand) bytes, and their 4-bit nybbles,
and extract them in correct order.

Since we bypass system printf, we need to do our own aligning, filling,
rounding, and other printf logic.

2 files changed, 120 insertions, 3 deletions

diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 4c41b16ada..74bf130af5 100644
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -179,7 +179,7 @@ __END__
 >%6. 6s<    >''<          >%6. 6s INVALID REDUNDANT< >(See use of $w in code above)<
 >%6 .6s<    >''<          >%6 .6s INVALID REDUNDANT<
 >%6.6 s<    >''<          >%6.6 s INVALID REDUNDANT<
->%A<        >''<          >%A INVALID REDUNDANT<
+>%A<        >0<           ><	 >%A tested in sprintf2.t skip: all<
 >%B<        >2**32-1<     >11111111111111111111111111111111<
 >%+B<       >2**32-1<     >11111111111111111111111111111111<
 >%#B<       >2**32-1<     >0B11111111111111111111111111111111<
@@ -213,7 +213,7 @@ __END__
 >%#X<       >2**32-1<     >0XFFFFFFFF<
 >%Y<        >''<          >%Y INVALID REDUNDANT<
 >%Z<        >''<          >%Z INVALID REDUNDANT<
->%a<        >''<          >%a INVALID REDUNDANT<
+>%a<        >0<           ><	 >%a tested in sprintf2.t skip: all<
 >%b<        >2**32-1<     >11111111111111111111111111111111<
 >%+b<       >2**32-1<     >11111111111111111111111111111111<
 >%#b<       >2**32-1<     >0b11111111111111111111111111111111<
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 6fd0bde072..311593d400 100644
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -12,7 +12,117 @@ BEGIN {
 eval { my $q = pack "q", 0 };
 my $Q = $@ eq '';
 
-plan tests => 1406 + ($Q ? 0 : 12);
+# %a and %A depend on the floating point config
+# This totally doesn't test non-IEEE-754 float formats.
+my @hexfloat;
+print "# uvsize = $Config{uvsize}\n";
+print "# nvsize = $Config{nvsize}\n";
+print "# nv_preserves_uv_bits = $Config{nv_preserves_uv_bits}\n";
+print "# d_quad = $Config{d_quad}\n";
+if ($Config{nvsize} == 8 &&
+    (
+     # IEEE-754, we hope, the most common out there.
+     ($Config{uvsize} == 8 && $Config{nv_preserves_uv_bits} == 53)
+     ||
+     # If we have a quad we get still get the mantissa bits.
+     ($Config{uvsize} == 4&&  $Config{d_quad})
+     )
+    ) {
+    @hexfloat =  (
+        [ '%a',       '0',       '0x0p+0' ],
+        [ '%a',       '1',       '0x1p+0' ],
+        [ '%a',       '1.0',     '0x1p+0' ],
+        [ '%a',       '0.5',     '0x1p-1' ],
+        [ '%a',       '0.25',    '0x1p-2' ],
+        [ '%a',       '0.75',    '0x1.8p-1' ],
+        [ '%a',       '3.14',    '0x1.91eb851eb851fp+1' ],
+        [ '%a',       '-1.0',    '-0x1p+0' ],
+        [ '%a',       '-3.14',   '-0x1.91eb851eb851fp+1' ],
+        [ '%a',       '0.1',     '0x1.999999999999ap-4' ],
+        [ '%a',       '1/7',     '0x1.2492492492492p-3' ],
+        [ '%a',       'sqrt(2)', '0x1.6a09e667f3bcdp+0' ],
+        [ '%a',       'exp(1)',  '0x1.5bf0a8b145769p+1' ],
+        [ '%a',       '2**-10',  '0x1p-10' ],
+        [ '%a',       '2**10',   '0x1p+10' ],
+        [ '%a',       '1e-9',    '0x1.12e0be826d695p-30' ],
+        [ '%a',       '1e9',     '0x1.dcd65p+29' ],
+
+        [ '%#a',      '1',       '0x1.p+0' ],
+        [ '%+a',      '1',       '+0x1p+0' ],
+        [ '%+a',      '-1',      '-0x1p+0' ],
+        [ '% a',      ' 1',      ' 0x1p+0' ],
+        [ '% a',      '-1',      '-0x1p+0' ],
+
+        [ '%8a',      '3.14',   '0x1.91eb851eb851fp+1' ],
+        [ '%13a',     '3.14',   '0x1.91eb851eb851fp+1' ],
+        [ '%20a',     '3.14',   '0x1.91eb851eb851fp+1' ],
+        [ '%.4a',     '3.14',   '0x1.91ecp+1' ],
+        [ '%.5a',     '3.14',   '0x1.91eb8p+1' ],
+        [ '%.6a',     '3.14',   '0x1.91eb85p+1' ],
+        [ '%.20a',    '3.14',   '0x1.91eb851eb851f0000000p+1' ],
+        [ '%20.10a',  '3.14',   '   0x1.91eb851eb8p+1' ],
+        [ '%20.15a',  '3.14',   '0x1.91eb851eb851f00p+1' ],
+        [ '% 20.10a', '3.14',   '   0x1.91eb851eb8p+1' ],
+        [ '%020.10a', '3.14',   '0x0001.91eb851eb8p+1' ],
+
+        [ '%30a',  '3.14',   '          0x1.91eb851eb851fp+1' ],
+        [ '%-30a', '3.14',   '0x1.91eb851eb851fp+1          ' ],
+        [ '%030a',  '3.14',  '0x00000000001.91eb851eb851fp+1' ],
+        [ '%-030a', '3.14',  '0x1.91eb851eb851fp+1          ' ],
+
+        [ '%A',       '3.14',   '0X1.91EB851EB851FP+1' ],
+        );
+} elsif ($Config{nvsize} == 16 || $Config{nvsize} == 12) {
+    # x86 long double, at least
+    @hexfloat =  (
+        [ '%a',       '0',       '0x0p+0' ],
+        [ '%a',       '1',       '0x8p-3' ],
+        [ '%a',       '1.0',     '0x8p-3' ],
+        [ '%a',       '0.5',     '0x8p-4' ],
+        [ '%a',       '0.25',    '0x8p-5' ],
+        [ '%a',       '0.75',    '0xcp-4' ],
+        [ '%a',       '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%a',       '-1.0',    '-0x8p-3' ],
+        [ '%a',       '-3.14',   '-0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%a',       '0.1',     '0xc.ccccccccccccccdp-7' ],
+        [ '%a',       '1/7',     '0x9.249249249249249p-6' ],
+        [ '%a',       'sqrt(2)', '0xb.504f333f9de6484p-3' ],
+        [ '%a',       'exp(1)',  '0xa.df85458a2bb4a9bp-2' ],
+        [ '%a',       '2**-10',  '0x8p-13' ],
+        [ '%a',       '2**10',   '0x8p+7' ],
+        [ '%a',       '1e-9',    '0x8.9705f4136b4a597p-33' ],
+        [ '%a',       '1e9',     '0xe.e6b28p+26' ],
+
+        [ '%#a',      '1',       '0x8.p-3' ],
+        [ '%+a',      '1',       '+0x8p-3' ],
+        [ '%+a',      '-1',      '-0x8p-3' ],
+        [ '% a',      ' 1',      ' 0x8p-3' ],
+        [ '% a',      '-1',      '-0x8p-3' ],
+
+        [ '%8a',      '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%13a',     '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%20a',     '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%.4a',     '3.14',    '0xc.8f5cp-2' ],
+        [ '%.5a',     '3.14',    '0xc.8f5c3p-2' ],
+        [ '%.6a',     '3.14',    '0xc.8f5c29p-2' ],
+        [ '%.20a',    '3.14',    '0xc.8f5c28f5c28f5c300000p-2' ],
+        [ '%20.10a',  '3.14',    '   0xc.8f5c28f5c3p-2' ],
+        [ '%20.15a',  '3.14',    '0xc.8f5c28f5c28f5c3p-2' ],
+        [ '% 20.10a', '3.14',    '   0xc.8f5c28f5c3p-2' ],
+        [ '%020.10a', '3.14',    '0x000c.8f5c28f5c3p-2' ],
+
+        [ '%30a',  '3.14',   '        0xc.8f5c28f5c28f5c3p-2' ],
+        [ '%-30a', '3.14',   '0xc.8f5c28f5c28f5c3p-2        ' ],
+        [ '%030a',  '3.14',  '0x00000000c.8f5c28f5c28f5c3p-2' ],
+        [ '%-030a', '3.14',  '0xc.8f5c28f5c28f5c3p-2        ' ],
+
+        [ '%A',       '3.14',    '0XC.8F5C28F5C28F5C3P-2' ],
+        );
+} else {
+    print "# no hexfloat tests\n";
+}
+
+plan tests => 1406 + ($Q ? 0 : 12) + @hexfloat;
 
 use strict;
 use Config;
@@ -336,3 +446,10 @@ is $o::count, '1', 'sprinf %1s overload count';
 $o::count = 0;
 () = sprintf "%.1s", $o;
 is $o::count, '1', 'sprinf %.1s overload count';
+
+for my $t (@hexfloat) {
+    my ($format, $arg, $expected) = @$t;
+    $arg = eval $arg;
+    my $result = sprintf($format, $arg);
+    is($result, $expected, "'$format' '$arg' -> '$result' cf '$expected'");
+}