In perl.git, the branch maint-5.24 has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/c161c8adb544825c980b8c0a695e6aa1c0fd0f45?hp=2f530c475e4ce18290dd29b16212b698f17e469f>

- Log -----------------------------------------------------------------
commit c161c8adb544825c980b8c0a695e6aa1c0fd0f45
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Mon Aug 15 17:49:51 2016 -0400

    Test data mistake was masked by mistaken fractional matching
    
    (Affected only double-double.)
    
    (cherry picked from commit 1bee6aebe39da1a4d681e8ea1b9d0329898a8407)

M       t/op/sprintf2.t

commit acfcc7b39b2c2013449064f79fd23a71a792821a
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Mon Aug 15 17:52:17 2016 -0400

    Do not deploy the fractional matching without fractions
    
    (cherry picked from commit dd1645173d8209e05c419b0f3edc9b1c0f9643a8)

M       t/op/sprintf2.t

commit 36cc39842f9617ec173d719d1c8d7c6cbd1a9887
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 17 21:37:07 2016 -0400

    Test subnormals with quadmath
    
    (cherry picked from commit de1a8b537348227e83c8efd15d3cb36d9ac646f5)

M       t/op/sprintf2.t

commit 2055596407872d29e75dbbae52a26df3f6be8e44
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 17 21:16:16 2016 -0400

    Define Perl_fp_class() for quadmath
    
    More importantly, define Perl_fp_class_denorm()
    so that hexfp subnormals work with printf %a.
    
    (cherry picked from commit b28053d1f063cb783e73b0596d1f58a21681fda6)

M       perl.h

commit 20df966d7ace0fe3e66dc966fd8e5024940ee11d
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Sun Aug 14 22:52:40 2016 -0400

    Handle subnormals of x86 80-bit
    
    (cherry picked from commit f40ac91c3b9891b83f3d253861009c290584b646)

M       perl.h
M       sv.c
M       t/op/sprintf2.t

commit 865f60cb2a1a372f004ba8a8b99fa3d61afc090d
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Sun Aug 14 19:59:32 2016 -0400

    Use library testing for subnormality
    
    ...instead of implementing it brokenly
    
    Continuing work on rt.perl.org #128843
    
    (cherry picked from commit f5a466613ec0b74a224adb5b7da6da0a74713596)

M       sv.c
M       t/op/sprintf2.t

commit dd93a6f33f343b17c49733047b4cc962d5c34929
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Sun Aug 14 10:16:55 2016 -0400

    Follow-up on a149d118.
    
    The added tests were meant only for x86-80-bit long doubles,
    but were accidentally run also on 128-bit doubles (quadmath,
    or probably also on true IEEE 754 quadruples).
    
    (cherry picked from commit 7301378635b35757b228e07c14276afaf06a4728)

M       t/op/hexfp.t

commit cf834f40206e0a0c50ba4259882478cb5e31276f
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Sat Aug 13 19:13:58 2016 -0400

    [perl #128919] limited exponent range in hex fp literal with long double
    
    (cherry picked from commit a149d1180209525972d84fd1a62f488da83e568a)

M       t/op/hexfp.t
M       toke.c

commit 6e03e445e8f3ae75b3f2fc4facc288cce3c1fb9e
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Fri Aug 12 19:08:56 2016 -0400

    Avoid test noise on non-longdouble.
    
    (cherry picked from commit 9e67a8c1b21482ed5fada053dd462eb23320dc86)

M       t/op/sprintf2.t

commit 79314a4f38d4e66f5f4f7abf4726748163c07c90
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Fri Aug 12 17:36:58 2016 -0400

    [rt.perl.org #128909] printf %a mishandles exponent-crossing rounding with 
long double
    
    (cherry picked from commit ee58923a8531731f8acb98ab130abf41f75ebdc7)

M       sv.c
M       t/op/sprintf2.t

commit 3d1a8d12c01c9ebed0c52169733b593180901b7a
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Fri Aug 12 17:30:25 2016 -0400

    Bogus skip count.
    
    Didn't break anything but still bogus.
    
    (cherry picked from commit 44348173fce5aaf28fdf59ba6ace73ea435d9380)

M       t/op/sprintf2.t

commit 0b150a8c37968149fde5f5a7fe65806e746b7bde
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Fri Aug 12 08:12:41 2016 -0400

    Test new hexfp fixes also on (x86 80-bit) long doubles.
    
    (cherry picked from commit e3f7a67e8485950fdf5fd9c7131d0a78b6c8cf32)

M       t/op/sprintf2.t

commit 559bb126ed8b27d5f85a10919d0f0627115a47c3
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Thu Aug 11 19:53:30 2016 -0400

    Fix on top of 75326c48.
    
    Worked partly accidentally, and as a bonus caused asan
    off-stack-variable read violations.
    
    (cherry picked from commit 5208a0305e9e82c534fa034515d54a0409dfcc77)

M       sv.c
M       t/op/sprintf2.t

commit 2d197ba4766455fd01a1e589fbed44e038068de6
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Thu Aug 11 18:19:00 2016 -0400

    The new tests are valid only for IEEE 754 64-bit doubles.
    
    The tests do not fail (I wish), they would just need to be different
    for example for the 80-bt x86 long doubles, for example, which scale
    differently:
    
        perl -wle 'printf "%a\n", -1.5'  # IEEE 754 64-bit
        -0x1.8+0
        perl -wle 'printf "%a\n", -1.5'  # x86 80-bit
        -0xcp-3
    
    In any system:
    
        perl -wle 'print -0x1.8p+0'
        -1.5
        perl -wle 'print -0xcp-3'
        -1.5
    
    See earlier in this file a long if-elsif chain when testing
    the @hexfloat because of this very same reason.
    
    (cherry picked from commit 749d85343f3cdb65891a5fe3b9f55ef3a5b03ca8)

M       t/op/sprintf2.t

commit 777da0c71e23fed33be4b97b417f5f4852f3f4b3
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Thu Aug 11 09:18:27 2016 -0400

    [rt.perl.org #128893]: printf %a botches 0 flag for negative values
    
    (cherry picked from commit be93048a43d87d317acca5b37619111b6a5f8c44)

M       sv.c
M       t/op/sprintf2.t

commit 82eac499d4642883519ed7ae8b97eda2e06028d2
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Thu Aug 11 09:15:21 2016 -0400

    [rt.perl.org #128890]: printf %a rounds incorrectly
    
    (cherry picked from commit 75326c485e9d40be5c22d508f581cdea68b244ce)

M       sv.c
M       t/op/sprintf2.t

commit 05573adb7c5e6b7556e38a2711a07695206cc769
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Thu Aug 11 09:12:04 2016 -0400

    [rt.perl.org #128889]: printf %a mishandles negative pseudo-precision
    
    (the fix for [rt.perl.org #128888] fixed also this one)
    
    (cherry picked from commit a9ce335538454d590920dab8d62db84948f1fb83)

M       t/op/sprintf2.t

commit d15a497c9bb1d2a73a822955cad1abb2fbfb4b1f
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 10 19:06:03 2016 -0400

    [rt.perl.org #128888]: printf %a mishandles zero precision
    
    (cherry picked from commit 82229f9f47d9a169b59715582fb5a09b5a4ac0ff)

M       sv.c
M       t/op/sprintf2.t

commit 94cbfa8253168c403fd531381fa27326a207de64
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 10 19:47:19 2016 -0400

    Comment fix for b6d9b423
    
    (cherry picked from commit 520f3e58c346a7bc3ef0509dfe0db206dae454ee)

M       sv.c

commit 2c39aa7329599fa4268fb19cbaadceb42fbc8f84
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 10 19:13:36 2016 -0400

    Add rt.perl.org reference for b6d9b423
    
    (cherry picked from commit 94d00769fba240ffb86f18b3d66341fb1d24ae6c)

M       t/op/sprintf2.t

commit bc87b110ad0060342a7ad96338aebe75e7e10574
Author: Jarkko Hietaniemi <j...@iki.fi>
Date:   Wed Aug 9 13:19:16 2017 +0100

    hexfp: IEEE 754 subnormals printf %a
    
    (cherry picked from commit b6d9b423fab1963346eb79e83b356114396b1f2e)

M       perl.h
M       pod/perldiag.pod
M       sv.c
M       t/op/sprintf2.t
M       toke.c
-----------------------------------------------------------------------

Summary of changes:
 perl.h           |  11 ++-
 pod/perldiag.pod |   4 +-
 sv.c             | 207 +++++++++++++++++++++++++++++++++++++++----------------
 t/op/hexfp.t     |  15 +++-
 t/op/sprintf2.t  | 164 +++++++++++++++++++++++++++++++++++++++++--
 toke.c           |  10 ++-
 6 files changed, 344 insertions(+), 67 deletions(-)

diff --git a/perl.h b/perl.h
index 7080620489..6c28aac5d2 100644
--- a/perl.h
+++ b/perl.h
@@ -2022,6 +2022,12 @@ extern long double Perl_my_frexpl(long double x, int *e);
 #   define Perl_isinf(x) isinfq(x)
 #   define Perl_isnan(x) isnanq(x)
 #   define Perl_isfinite(x) !(isnanq(x) || isinfq(x))
+#   define Perl_fp_class(x) ((x) == 0.0Q ? 0 : isinfq(x) ? 3 : isnanq(x) ? 4 : 
PERL_ABS(x) < FLT128_MIN ? 2 : 1)
+#   define Perl_fp_class_inf(x)    (Perl_fp_class(x) == 3)
+#   define Perl_fp_class_nan(x)    (Perl_fp_class(x) == 4)
+#   define Perl_fp_class_norm(x)   (Perl_fp_class(x) == 1)
+#   define Perl_fp_class_denorm(x) (Perl_fp_class(x) == 2)
+#   define Perl_fp_class_zero(x)   (Perl_fp_class(x) == 0)
 #else
 #   define NV_DIG DBL_DIG
 #   ifdef DBL_MANT_DIG
@@ -6758,7 +6764,9 @@ extern void moncontrol(int);
 #endif
 
 /* All the basic IEEE formats have the implicit bit,
- * except for the 80-bit extended formats, which will undef this. */
+ * except for the x86 80-bit extended formats, which will undef this.
+ * Also note that the IEEE 754 subnormals (formerly known as denormals)
+ * do not have the implicit bit of one. */
 #define NV_IMPLICIT_BIT
 
 #ifdef LONG_DOUBLEKIND
@@ -6785,6 +6793,7 @@ extern void moncontrol(int);
 #    define LONGDOUBLE_X86_80_BIT
 #    ifdef USE_LONG_DOUBLE
 #      undef NV_IMPLICIT_BIT
+#      define NV_X86_80_BIT
 #    endif
 #  endif
 
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 78aeb164e3..737d3633f6 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2479,7 +2479,9 @@ than the floating point supports.
 =item Hexadecimal float: exponent underflow
 
 (W overflow) The hexadecimal floating point has a smaller exponent
-than the floating point supports.
+than the floating point supports.  With the IEEE 754 floating point,
+this may also mean that the subnormals (formerly known as denormals)
+are being used, which may or may not be an error.
 
 =item Hexadecimal float: internal error (%s)
 
diff --git a/sv.c b/sv.c
index ec5b344127..80bf2fe716 100644
--- a/sv.c
+++ b/sv.c
@@ -10985,8 +10985,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const 
pat, const STRLEN patlen,
  * the hexadecimal values (for %a/%A).  The nv is the NV where the value
  * are being extracted from (either directly from the long double in-memory
  * presentation, or from the uquad computed via frexp+ldexp).  frexp also
- * is used to update the exponent.  vhex is the pointer to the beginning
- * of the output buffer (of VHEX_SIZE).
+ * is used to update the exponent.  The subnormal is set to true
+ * for IEEE 754 subnormals/denormals (including the x86 80-bit format).
+ * The vhex is the pointer to the beginning of the output buffer of VHEX_SIZE.
  *
  * The tricky part is that S_hextract() needs to be called twice:
  * the first time with vend as NULL, and the second time with vend as
@@ -10996,14 +10997,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char 
*const pat, const STRLEN patlen,
  * (the extraction of the hexadecimal values) takes place.
  * Sanity failures cause fatal failures during both rounds. */
 STATIC U8*
-S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal,
+           U8* vhex, U8* vend)
 {
     U8* v = vhex;
     int ix;
     int ixmin = 0, ixmax = 0;
 
-    /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
-     * and elsewhere. */
+    /* XXX Inf/NaN are not handled here, since it is
+     * assumed they are to be output as "Inf" and "NaN". */
 
     /* These macros are just to reduce typos, they have multiple
      * repetitions below, but usually only one (or sometimes two)
@@ -11036,13 +11038,20 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* 
vhex, U8* vend)
     for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
 #define HEXTRACT_BYTES_BE(a, b) \
     for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_GET_SUBNORMAL(nv) *subnormal = Perl_fp_class_denorm(nv)
 #define HEXTRACT_IMPLICIT_BIT(nv) \
     STMT_START { \
-        if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+        if (!*subnormal) { \
+            if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+        } \
    } STMT_END
 
-/* Most formats do.  Those which don't should undef this. */
+/* Most formats do.  Those which don't should undef this.
+ *
+ * But also note that IEEE 754 subnormals do not have it, or,
+ * expressed alternatively, their implicit bit is zero. */
 #define HEXTRACT_HAS_IMPLICIT_BIT
+
 /* Many formats do.  Those which don't should undef this. */
 #define HEXTRACT_HAS_TOP_NYBBLE
 
@@ -11056,6 +11065,7 @@ 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);
+    *subnormal = FALSE;
     if (vend && (vend <= vhex || vend > vmaxend)) {
         /* diag_listed_as: Hexadecimal float: internal error (%s) */
         Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
@@ -11065,10 +11075,11 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* 
vhex, U8* vend)
 #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
 #  if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
         /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
-         * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+         * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb bf */
         /* The bytes 13..0 are the mantissa/fraction,
          * the 15,14 are the sign+exponent. */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
 #   undef HEXTRACT_HAS_TOP_NYBBLE
         HEXTRACT_BYTES_LE(13, 0);
@@ -11078,18 +11089,21 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* 
vhex, U8* vend)
         /* The bytes 2..15 are the mantissa/fraction,
          * the 0,1 are the sign+exponent. */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
 #   undef HEXTRACT_HAS_TOP_NYBBLE
         HEXTRACT_BYTES_BE(2, 15);
 #  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
         /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
-         * significand, 15 bits of exponent, 1 bit of sign.  NVSIZE can
-         * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
-         * meaning that 2 or 6 bytes are empty padding. */
-        /* The bytes 7..0 are the mantissa/fraction */
+         * significand, 15 bits of exponent, 1 bit of sign.  No implicit bit.
+         * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux
+         * and OS X), meaning that 2 or 6 bytes are empty padding. */
+        /* The bytes 0..1 are the sign+exponent,
+        * the bytes 2..9 are the mantissa/fraction. */
         const U8* nvp = (const U8*)(&nv);
 #    undef HEXTRACT_HAS_IMPLICIT_BIT
 #    undef HEXTRACT_HAS_TOP_NYBBLE
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_BYTES_LE(7, 0);
 #  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
         /* Does this format ever happen? (Wikipedia says the Motorola
@@ -11099,6 +11113,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, 
U8* vend)
         const U8* nvp = (const U8*)(&nv);
 #    undef HEXTRACT_HAS_IMPLICIT_BIT
 #    undef HEXTRACT_HAS_TOP_NYBBLE
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_BYTES_BE(0, 7);
 #  else
 #    define HEXTRACT_FALLBACK
@@ -11134,18 +11149,21 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* 
vhex, U8* vend)
 #    ifdef HEXTRACT_LITTLE_ENDIAN
         /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
         HEXTRACT_TOP_NYBBLE(6);
         HEXTRACT_BYTES_LE(5, 0);
 #    elif defined(HEXTRACT_BIG_ENDIAN)
         /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
         HEXTRACT_TOP_NYBBLE(1);
         HEXTRACT_BYTES_BE(2, 7);
 #    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
         /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
         HEXTRACT_TOP_NYBBLE(2); /* 6 */
         HEXTRACT_BYTE(1); /* 5 */
@@ -11157,6 +11175,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, 
U8* vend)
 #    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
         /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
         const U8* nvp = (const U8*)(&nv);
+       HEXTRACT_GET_SUBNORMAL(nv);
         HEXTRACT_IMPLICIT_BIT(nv);
         HEXTRACT_TOP_NYBBLE(5); /* 6 */
         HEXTRACT_BYTE(6); /* 5 */
@@ -11173,6 +11192,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, 
U8* vend)
 #  endif
 #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
 #  ifdef HEXTRACT_FALLBACK
+       HEXTRACT_GET_SUBNORMAL(nv);
 #    undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
         /* The fallback is used for the double-double format, and
          * for unknown long double formats, and for unknown double
@@ -12404,6 +12424,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char 
*const pat, const STRLEN p
                 U8* vend; /* pointer to one beyond last digit of vhex */
                 U8* vfnz = NULL; /* first non-zero */
                 U8* vlnz = NULL; /* last non-zero */
+                U8* v0 = NULL; /* first output */
                 const bool lower = (c == 'a');
                 /* At output the values of vhex (up to vend) will
                  * be mapped through the xdig to get the actual
@@ -12412,33 +12433,47 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char 
*const pat, const STRLEN p
                 int zerotail = 0; /* how many extra zeros to append */
                 int exponent = 0; /* exponent of the floating point input */
                 bool hexradix = FALSE; /* should we output the radix */
+                bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */
+                bool negative = FALSE;
 
-                /* XXX: denormals, NaN, Inf.
+                /* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf".
                  *
                  * For example with denormals, (assuming the vanilla
                  * 64-bit double): the exponent is zero. 1xp-1074 is
                  * the smallest denormal and the smallest double, it
-                 * should be output as 0x0.0000000000001p-1022 to
+                 * could be output also as 0x0.0000000000001p-1022 to
                  * match its internal structure. */
 
-                vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
-                S_hextract(aTHX_ nv, &exponent, vhex, vend);
+                vend = S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, NULL);
+                S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, vend);
 
 #if NVSIZE > DOUBLESIZE
 #  ifdef HEXTRACT_HAS_IMPLICIT_BIT
                 /* In this case there is an implicit bit,
-                 * and therefore the exponent is shifted shift by one. */
+                 * and therefore the exponent is shifted by one. */
                 exponent--;
 #  else
-                /* In this case there is no implicit bit,
-                 * and the exponent is shifted by the first xdigit. */
-                exponent -= 4;
+#   ifdef NV_X86_80_BIT
+                if (subnormal) {
+                    /* The subnormals of the x86-80 have a base exponent of 
-16382,
+                     * (while the physical exponent bits are zero) but the 
frexp()
+                     * returned the scientific-style floating exponent.  We 
want
+                     * to map the last one as:
+                     * -16831..-16384 -> -16382 (the last normal is 0x1p-16382)
+                     * -16835..-16388 -> -16384
+                     * since we want to keep the first hexdigit
+                     * as one of the [8421]. */
+                    exponent = -4 * ( (exponent + 1) / -4) - 2;
+                } else {
+                    exponent -= 4;
+                }
+#   endif
+                /* TBD: other non-implicit-bit platforms than the x86-80. */
 #  endif
 #endif
 
-                if (fv < 0
-                    || Perl_signbit(nv)
-                  )
+                negative = fv < 0 || Perl_signbit(nv);
+                if (negative)
                     *p++ = '-';
                 else if (plus)
                     *p++ = plus;
@@ -12473,50 +12508,98 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char 
*const pat, const STRLEN p
                         exponent--;
 #endif
 
-                    if (precis > 0) {
-                        if ((SSize_t)(precis + 1) < vend - vhex) {
-                            bool round;
-
-                            v = vhex + precis + 1;
-                            /* Round away from zero: if the tail
-                             * beyond the precis xdigits is equal to
-                             * or greater than 0x8000... */
-                            round = *v > 0x8;
-                            if (!round && *v == 0x8) {
-                                for (v++; v < vend; v++) {
-                                    if (*v) {
-                                        round = TRUE;
-                                        break;
-                                    }
+                    if (subnormal) {
+#ifndef NV_X86_80_BIT
+                      if (vfnz[0] > 1) {
+                        /* IEEE 754 subnormals (but not the x86 80-bit):
+                         * we want "normalize" the subnormal,
+                        * so we need to right shift the hex nybbles
+                         * so that the output of the subnormal starts
+                         * from the first true bit.  (Another, equally
+                        * valid, policy would be to dump the subnormal
+                        * nybbles as-is, to display the "physical" layout.) */
+                        int i, n;
+                        U8 *vshr;
+                        /* Find the ceil(log2(v[0])) of
+                         * the top non-zero nybble. */
+                        for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { }
+                        assert(n < 4);
+                        vlnz[1] = 0;
+                        for (vshr = vlnz; vshr >= vfnz; vshr--) {
+                          vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n);
+                          vshr[0] >>= n;
+                        }
+                        if (vlnz[1]) {
+                          vlnz++;
+                        }
+                      }
+#endif
+                      v0 = vfnz;
+                    } else {
+                      v0 = vhex;
+                    }
+
+                    if (has_precis) {
+                        U8* ve = (subnormal ? vlnz + 1 : vend);
+                        SSize_t vn = ve - (subnormal ? vfnz : vhex);
+                        if ((SSize_t)(precis + 1) < vn) {
+                            bool overflow = FALSE;
+                            if (v0[precis + 1] < 0x8) {
+                                /* Round down, nothing to do. */
+                            } else if (v0[precis + 1] > 0x8) {
+                                /* Round up. */
+                                v0[precis]++;
+                                overflow = v0[precis] > 0xF;
+                                v0[precis] &= 0xF;
+                            } else { /* v0[precis] == 0x8 */
+                                /* Half-point: round towards the one
+                                 * with the even least-significant digit:
+                                 * 08 -> 0  88 -> 8
+                                 * 18 -> 2  98 -> a
+                                 * 28 -> 2  a8 -> a
+                                 * 38 -> 4  b8 -> c
+                                 * 48 -> 4  c8 -> c
+                                 * 58 -> 6  d8 -> e
+                                 * 68 -> 6  e8 -> e
+                                 * 78 -> 8  f8 -> 10 */
+                                if ((v0[precis] & 0x1)) {
+                                    v0[precis]++;
                                 }
+                                overflow = v0[precis] > 0xF;
+                                v0[precis] &= 0xF;
                             }
-                            if (round) {
-                                for (v = vhex + precis; v >= vhex; v--) {
-                                    if (*v < 0xF) {
-                                        (*v)++;
+
+                            if (overflow) {
+                                for (v = v0 + precis - 1; v >= v0; v--) {
+                                    (*v)++;
+                                    overflow = *v > 0xF;
+                                    (*v) &= 0xF;
+                                    if (!overflow) {
                                         break;
                                     }
-                                    *v = 0;
-                                    if (v == vhex) {
-                                        /* If the carry goes all the way to
-                                         * the front, we need to output
-                                         * a single '1'. This goes against
-                                         * the "xdigit and then radix"
-                                         * but since this is "cannot happen"
-                                         * category, that is probably good. */
-                                        *p++ = xdig[1];
-                                    }
+                                }
+                                if (v == v0 - 1 && overflow) {
+                                    /* If the overflow goes all the
+                                     * way to the front, we need to
+                                     * insert 0x1 in front, and adjust
+                                     * the exponent. */
+                                    Move(v0, v0 + 1, vn, char);
+                                    *v0 = 0x1;
+                                    exponent += 4;
                                 }
                             }
+
                             /* The new effective "last non zero". */
-                            vlnz = vhex + precis;
+                            vlnz = v0 + precis;
                         }
                         else {
-                            zerotail = precis - (vlnz - vhex);
+                            zerotail =
+                              subnormal ? precis - vn + 1 :
+                              precis - (vlnz - vhex);
                         }
                     }
 
-                    v = vhex;
+                    v = v0;
                     *p++ = xdig[*v++];
 
                     /* If there are non-zero xdigits, the radix
@@ -12576,12 +12659,18 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char 
*const pat, const STRLEN p
                         memset(PL_efloatbuf + elen, ' ', width - elen);
                     }
                     else if (fill == '0') {
-                        /* Insert the zeros between the "0x" and
-                         * the digits, otherwise we end up with
-                         * "0000xHHH..." */
+                        /* Insert the zeros after the "0x" and the
+                         * the potential sign, but before the digits,
+                         * otherwise we end up with "0000xH.HHH...",
+                         * when we want "0x000H.HHH..."  */
                         STRLEN nzero = width - elen;
                         char* zerox = PL_efloatbuf + 2;
-                        Move(zerox, zerox + nzero,  elen - 2, char);
+                        STRLEN nmove = elen - 2;
+                        if (negative || plus) {
+                            zerox++;
+                            nmove--;
+                        }
+                        Move(zerox, zerox + nzero, nmove, char);
                         memset(zerox, fill, nzero);
                     }
                     else {
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
index 4b2a96d051..c4c08cc3f0 100644
--- a/t/op/hexfp.t
+++ b/t/op/hexfp.t
@@ -10,7 +10,7 @@ use strict;
 
 use Config;
 
-plan(tests => 105);
+plan(tests => 109);
 
 # Test hexfloat literals.
 
@@ -243,6 +243,19 @@ SKIP:
     }
 }
 
+# [perl #128919] limited exponent range in hex fp literal with long double
+SKIP: {
+    skip("non-80-bit-long-double", 4)
+        unless ($Config{uselongdouble} &&
+               ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
+               ($Config{longdblkind} == 3 ||
+                $Config{longdblkind} == 4));
+    is(0x1p-1074,  4.94065645841246544e-324);
+    is(0x1p-1075,  2.47032822920623272e-324, '[perl #128919]');
+    is(0x1p-1076,  1.23516411460311636e-324);
+    is(0x1p-16445, 3.6451995318824746e-4951);
+}
+
 # sprintf %a/%A testing is done in sprintf2.t,
 # trickier than necessary because of long doubles,
 # and because looseness of the spec.
diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 43ed919be5..7b1d2c4567 100644
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -21,6 +21,7 @@ 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";
+print "# uselongdouble = " . ($Config{uselongdouble} // 'undef') . "\n";
 if ($Config{nvsize} == 8 &&
     (
      # IEEE-754 64-bit ("double precision"), the most common out there
@@ -219,7 +220,7 @@ if ($Config{nvsize} == 8 &&
        [ '%a', '0.25',    '0x1p-2' ],
        [ '%a', '0.75',    '0x1.8p-1' ],
        [ '%a', '3.14',    '0x1.91eb851eb851eb851eb851eb85p+1' ],
-       [ '%a', '-1',      '-0x0p+0' ],
+       [ '%a', '-1',      '-0x1p+0' ],
        [ '%a', '-3.14',   '-0x1.91eb851eb851eb851eb851eb85p+1' ],
        [ '%a', '0.1',     '0x1.999999999999999999999999998p-4' ],
        [ '%a', '1/7',     '0x1.249249249249249249249249248p-3' ],
@@ -262,8 +263,6 @@ if ($Config{nvsize} == 8 &&
     print "# no hexfloat tests\n";
 }
 
-plan tests => 1408 + ($Q ? 0 : 12) + @hexfloat + 12;
-
 use strict;
 use Config;
 
@@ -622,7 +621,7 @@ for my $t (@hexfloat) {
         ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
         next;
     }
-    unless ($ok) {
+    if (!$ok && $result =~ /\./ && $expected =~ /\./) {
         # It seems that there can be difference in the last bits:
         # [perl #122578]
         #      got "0x1.5bf0a8b14576ap+1"
@@ -721,6 +720,7 @@ SKIP: {
 SKIP: {
     # [perl #127183] Non-canonical hexadecimal floats are parsed prematurely
 
+    # IEEE 754 64-bit
     skip("nv_preserves_uv_bits is $Config{nv_preserves_uv_bits}, not 53", 3)
         unless $Config{nv_preserves_uv_bits} == 53;
 
@@ -749,3 +749,159 @@ SKIP: {
            "non-canonical form");
     }
 }
+
+# These are IEEE 754 64-bit subnormals (formerly known as denormals).
+# Keep these as strings so that non-IEEE-754 don't trip over them.
+my @subnormals = (
+    [ '1e-320', '%a', '0x1.fap-1064' ],
+    [ '1e-321', '%a', '0x1.94p-1067' ],
+    [ '1e-322', '%a', '0x1.4p-1070' ],
+    [ '1e-323', '%a', '0x1p-1073' ],
+    [ '1e-324', '%a', '0x0p+0' ],  # underflow
+    [ '3e-320', '%a', '0x1.7b8p-1062' ],
+    [ '3e-321', '%a', '0x1.2f8p-1065' ],
+    [ '3e-322', '%a', '0x1.e8p-1069' ],
+    [ '3e-323', '%a', '0x1.8p-1072' ],
+    [ '3e-324', '%a', '0x1p-1074' ], # the smallest possible value
+    [ '7e-320', '%a', '0x1.bacp-1061' ],
+    [ '7e-321', '%a', '0x1.624p-1064' ],
+    [ '7e-322', '%a', '0x1.1cp-1067' ],
+    [ '7e-323', '%a', '0x1.cp-1071' ],
+    [ '7e-324', '%a', '0x1p-1074' ], # the smallest possible value, again
+    [ '3e-320', '%.4a', '0x1.7b80p-1062' ],
+    [ '3e-321', '%.4a', '0x1.2f80p-1065' ],
+    [ '3e-322', '%.4a', '0x1.e800p-1069' ],
+    [ '3e-323', '%.4a', '0x1.8000p-1072' ],
+    [ '3e-324', '%.4a', '0x1.0000p-1074' ],
+    [ '3e-320', '%.1a', '0x1.8p-1062' ],
+    [ '3e-321', '%.1a', '0x1.3p-1065' ],
+    [ '3e-322', '%.1a', '0x1.ep-1069' ],
+    [ '3e-323', '%.1a', '0x1.8p-1072' ],
+    [ '3e-324', '%.1a', '0x1.0p-1074' ],
+    [ '0x1.fffffffffffffp-1022', '%a', '0x1.fffffffffffffp-1022' ],
+    [ '0x0.fffffffffffffp-1022', '%a', '0x1.ffffffffffffep-1023' ],
+    [ '0x0.7ffffffffffffp-1022', '%a', '0x1.ffffffffffffcp-1024' ],
+    [ '0x0.3ffffffffffffp-1022', '%a', '0x1.ffffffffffff8p-1025' ],
+    [ '0x0.1ffffffffffffp-1022', '%a', '0x1.ffffffffffffp-1026' ],
+    [ '0x0.0ffffffffffffp-1022', '%a', '0x1.fffffffffffep-1027' ],
+    );
+
+SKIP: {
+    # [rt.perl.org #128843]
+    skip("non-IEEE-754-non-64-bit", scalar @subnormals + 34)
+        unless ($Config{nvsize} == 8 &&
+               $Config{nv_preserves_uv_bits} == 53 &&
+               ($Config{doublekind} == 3 ||
+                $Config{doublekind} == 4));
+
+    for my $t (@subnormals) {
+       # Note that "0x1p+2" is not considered numeric,
+       # since neither is "0x12", hence the eval.
+        my $s = sprintf($t->[1], eval $t->[0]);
+        is($s, $t->[2], "subnormal @$t got $s");
+    }
+
+    # [rt.perl.org #128888]
+    is(sprintf("%a", 1.03125),   "0x1.08p+0");
+    is(sprintf("%.1a", 1.03125), "0x1.0p+0");
+    is(sprintf("%.0a", 1.03125), "0x1p+0", "[rt.perl.org #128888]");
+
+    # [rt.perl.org #128889]
+    is(sprintf("%.*a", -1, 1.03125), "0x1.08p+0", "[rt.perl.org #128889]");
+
+    # [rt.perl.org #128890]
+    is(sprintf("%a", 0x1.18p+0), "0x1.18p+0");
+    is(sprintf("%.1a", 0x1.08p+0), "0x1.0p+0");
+    is(sprintf("%.1a", 0x1.18p+0), "0x1.2p+0", "[rt.perl.org #128890]");
+    is(sprintf("%.1a", 0x1.28p+0), "0x1.2p+0");
+    is(sprintf("%.1a", 0x1.38p+0), "0x1.4p+0");
+    is(sprintf("%.1a", 0x1.48p+0), "0x1.4p+0");
+    is(sprintf("%.1a", 0x1.58p+0), "0x1.6p+0");
+    is(sprintf("%.1a", 0x1.68p+0), "0x1.6p+0");
+    is(sprintf("%.1a", 0x1.78p+0), "0x1.8p+0");
+    is(sprintf("%.1a", 0x1.88p+0), "0x1.8p+0");
+    is(sprintf("%.1a", 0x1.98p+0), "0x1.ap+0");
+    is(sprintf("%.1a", 0x1.a8p+0), "0x1.ap+0");
+    is(sprintf("%.1a", 0x1.b8p+0), "0x1.cp+0");
+    is(sprintf("%.1a", 0x1.c8p+0), "0x1.cp+0");
+    is(sprintf("%.1a", 0x1.d8p+0), "0x1.ep+0");
+    is(sprintf("%.1a", 0x1.e8p+0), "0x1.ep+0");
+    is(sprintf("%.1a", 0x1.f8p+0), "0x2.0p+0");
+
+    is(sprintf("%.1a", 0x1.10p+0), "0x1.1p+0");
+    is(sprintf("%.1a", 0x1.17p+0), "0x1.1p+0");
+    is(sprintf("%.1a", 0x1.19p+0), "0x1.2p+0");
+    is(sprintf("%.1a", 0x1.1fp+0), "0x1.2p+0");
+
+    is(sprintf("%.2a", 0x1.fffp+0), "0x2.00p+0");
+    is(sprintf("%.2a", 0xf.fffp+0), "0x2.00p+3");
+
+    # [rt.perl.org #128893]
+    is(sprintf("%020a", 1.5), "0x0000000000001.8p+0");
+    is(sprintf("%020a", -1.5), "-0x000000000001.8p+0", "[rt.perl.org 
#128893]");
+    is(sprintf("%+020a", 1.5), "+0x000000000001.8p+0", "[rt.perl.org 
#128893]");
+    is(sprintf("% 020a", 1.5), " 0x000000000001.8p+0", "[rt.perl.org 
#128893]");
+    is(sprintf("%20a", -1.5), "           -0x1.8p+0");
+    is(sprintf("%+20a", 1.5), "           +0x1.8p+0");
+    is(sprintf("% 20a", 1.5), "            0x1.8p+0");
+}
+
+# x86 80-bit long-double tests for
+# rt.perl.org #128843, #128888, #128889, #128890, #128893, #128909
+SKIP: {
+    skip("non-80-bit-long-double", 17)
+        unless ($Config{uselongdouble} &&
+               ($Config{nvsize} == 16 || $Config{nvsize} == 12) &&
+               ($Config{longdblkind} == 3 ||
+                $Config{longdblkind} == 4));
+
+    {
+        # The last normal for this format.
+       is(sprintf("%a", eval '0x1p-16382'), "0x8p-16385", "[rt.perl.org 
#128843]");
+
+       # The subnormals cause "exponent underflow" warnings,
+        # but that is not why we are here.
+       local $SIG{__WARN__} = sub {
+           die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
+       };
+
+       is(sprintf("%a", eval '0x1p-16383'), "0x4p-16382", "[rt.perl.org 
#128843]");
+       is(sprintf("%a", eval '0x1p-16384'), "0x2p-16382", "[rt.perl.org 
#128843]");
+       is(sprintf("%a", eval '0x1p-16385'), "0x1p-16382", "[rt.perl.org 
#128843]");
+       is(sprintf("%a", eval '0x1p-16386'), "0x8p-16386", "[rt.perl.org 
#128843]");
+       is(sprintf("%a", eval '0x1p-16387'), "0x4p-16386", "[rt.perl.org 
#128843]");
+    }
+    is(sprintf("%.0a", 1.03125), "0x8p-3", "[rt.perl.org #128888]");
+    is(sprintf("%.*a", -1, 1.03125), "0x8.4p-3", "[rt.perl.org #128889]");
+    is(sprintf("%.1a", 0x8.18p+0), "0x8.2p+0", "[rt.perl.org #128890]");
+    is(sprintf("%020a", -1.5), "-0x0000000000000cp-3", "[rt.perl.org 
#128893]");
+    is(sprintf("%+020a", 1.5), "+0x0000000000000cp-3", "[rt.perl.org 
#128893]");
+    is(sprintf("% 020a", 1.5), " 0x0000000000000cp-3", "[rt.perl.org 
#128893]");
+    is(sprintf("%a", 1.9999999999999999999), "0xf.fffffffffffffffp-3");
+    is(sprintf("%.3a", 1.9999999999999999999), "0x1.000p+1", "[rt.perl.org 
#128909]");
+    is(sprintf("%.2a", 1.9999999999999999999), "0x1.00p+1");
+    is(sprintf("%.1a", 1.9999999999999999999), "0x1.0p+1");
+    is(sprintf("%.0a", 1.9999999999999999999), "0x1p+1");
+}
+
+# quadmath tests for rt.perl.org #128843
+SKIP: {
+    skip "need quadmath", 7, unless $Config{usequadmath};
+
+    is(sprintf("%a", eval '0x1p-16382'), '0x1p-16382');  # last normal
+
+    local $SIG{__WARN__} = sub {
+        die "$0: $_[0]" unless $_[0] =~ /exponent underflow/;
+    };
+
+    is(sprintf("%a", eval '0x1p-16383'), '0x1p-16383');
+    is(sprintf("%a", eval '0x1p-16384'), '0x1p-16384');
+
+    is(sprintf("%a", eval '0x1p-16491'), '0x1p-16491');
+    is(sprintf("%a", eval '0x1p-16492'), '0x1p-16492');
+    is(sprintf("%a", eval '0x1p-16493'), '0x1p-16493'); # last denormal
+
+    is(sprintf("%a", eval '0x1p-16494'), '0x1p-16494'); # underflow
+}
+
+done_testing();
diff --git a/toke.c b/toke.c
index f5f7fc3537..3e6839edde 100644
--- a/toke.c
+++ b/toke.c
@@ -10628,6 +10628,14 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 #ifdef NV_MIN_EXP
                                 if (negexp
                                     && -hexfp_exp < NV_MIN_EXP - 1) {
+                                    /* NOTE: this means that the exponent
+                                     * underflow warning happens for
+                                     * the IEEE 754 subnormals (denormals),
+                                     * because DBL_MIN_EXP etc are the lowest
+                                     * possible binary (or, rather, 
DBL_RADIX-base)
+                                     * exponent for normals, not subnormals.
+                                     *
+                                     * This may or may not be a good thing. */
                                     Perl_ck_warner(aTHX_ 
packWARN(WARN_OVERFLOW),
                                                    "Hexadecimal float: 
exponent underflow");
                                     break;
@@ -10649,7 +10657,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 #ifdef HEXFP_UQUAD
                         hexfp_exp -= hexfp_frac_bits;
 #endif
-                        hexfp_mult = pow(2.0, hexfp_exp);
+                        hexfp_mult = Perl_pow(2.0, hexfp_exp);
                         hexfp = TRUE;
                         goto decimal;
                     }

--
Perl5 Master Repository

Reply via email to