double-double long double %a fixes

- reserve enough buffer space
- name the two different errors differently
- test around the problem spot

3 files changed, 32 insertions, 9 deletions

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 0c4f19961b..4f21dbe556 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2402,7 +2402,7 @@ than the floating point supports.
 (W overflow) The hexadecimal floating point has a smaller exponent
 than the floating point supports.
 
-=item Hexadecimal float: internal error
+=item Hexadecimal float: internal error (%s)
 
 (F) Something went horribly bad in hexadecimal float handling.
 
diff --git a/sv.c b/sv.c
index 383f53d638..dff55c95e9 100644
--- a/sv.c
+++ b/sv.c
@@ -1,4 +1,4 @@
-/*    sv.c
+/*    sv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
@@ -10713,7 +10713,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
  * The non-double-double-long-double overshoots since all bits of NV
  * are not mantissa bits, there are also exponent bits. */
 #ifdef LONGDOUBLE_DOUBLEDOUBLE
-#  define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
+#  define VHEX_SIZE (3+DOUBLEDOUBLE_MAXBITS/4)
 #else
 #  define VHEX_SIZE (1+(NVSIZE * 8)/4)
 #endif
@@ -10810,7 +10810,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
 
     /* HEXTRACTSIZE is the maximum number of xdigits. */
 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
-#  define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
+#  define HEXTRACTSIZE (2+DOUBLEDOUBLE_MAXBITS/4)
 #else
 #  define HEXTRACTSIZE 2 * NVSIZE
 #endif
@@ -10818,8 +10818,10 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
     const U8* vmaxend = vhex + HEXTRACTSIZE;
     PERL_UNUSED_VAR(ix); /* might happen */
     (void)Perl_frexp(PERL_ABS(nv), exponent);
-    if (vend && (vend <= vhex || vend > vmaxend))
-        Perl_croak(aTHX_ "Hexadecimal float: internal error");
+    if (vend && (vend <= vhex || vend > vmaxend)) {
+        /* diag_listed_as: Hexadecimal float: internal error (%s) */
+        Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
+    }
     {
         /* First check if using long doubles. */
 #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
@@ -11025,8 +11027,10 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
          * which is convenient since the HEXTRACTSIZE is tricky
          * for double-double. */
         ixmin < 0 || ixmax >= NVSIZE ||
-        (vend && v != vend))
-        Perl_croak(aTHX_ "Hexadecimal float: internal error");
+        (vend && v != vend)) {
+        /* diag_listed_as: Hexadecimal float: internal error (%s) */
+        Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)");
+    }
     return v;
 }
 
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 1a4dd3097d..023167b78a 100644
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -243,7 +243,7 @@ if ($Config{nvsize} == 8 &&
     print "# no hexfloat tests\n";
 }
 
-plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat;
+plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 6;
 
 use strict;
 use Config;
@@ -648,3 +648,22 @@ for my $t (@hexfloat) {
     }
     ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
 }
+
+# double-double long double %a special testing.
+SKIP: {
+    skip("$^O doublekind=$Config{doublekind}", 6)
+        unless ($Config{doublekind} == 4 && $^O eq 'linux');
+    # [rt.perl.org 125633]
+    like(sprintf("%La\n", (2**1020) + (2**-1072)),
+         qr/^0x1.0{522}1p\+1020$/);
+    like(sprintf("%La\n", (2**1021) + (2**-1072)),
+         qr/^0x1.0{523}8p\+1021$/);
+    like(sprintf("%La\n", (2**1022) + (2**-1072)),
+         qr/^0x1.0{523}4p\+1022$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1072)),
+         qr/^0x1.0{523}2p\+1023$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1073)),
+         qr/^0x1.0{523}1p\+1023$/);
+    like(sprintf("%La\n", (2**1023) + (2**-1074)),
+         qr/^0x1.0{524}8p\+1023$/);
+}