From 61fc91819ced2e3a5e25da9cbc9db5dcd0ef3cb7 Mon Sep 17 00:00:00 2001
From: TAKAI Kousuke <62541129+t-a-k@users.noreply.github.com>
Date: Wed, 12 Mar 2025 00:52:27 +0900
Subject: [PATCH] toke.c (Perl_scan_num): Handle hexadecimal floats with large
 significand

Hexadecimal floats whose significand (mantissa) part is too large to
fit in UV range (e.g. 0x1234567890.12p+1 for 32-bit UVs) used to be
parsed incorrectly.

t/op/hexfp.t: Added tests for hexadecimal floats with large significand
---
 pod/perldelta.pod |  8 ++++++++
 t/op/hexfp.t      | 37 ++++++++++++++++++++++++++++++++++++-
 toke.c            |  8 +++++---
 3 files changed, 49 insertions(+), 4 deletions(-)

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 4e87d9d6228b..7eae158e5eae 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -379,6 +379,14 @@ manager will later use a regex to expand these into links.
 
 =item *
 
+Fix parsing of hexadecimal floating-point numbers whose significand
+(aka "mantissa") values are too large to fit in UV range.
+Such literals (for example, C<0x1234567890.1p+0> for 32-bit IV/UV
+platform, or C<0x1234567890_1234567890.1p+0> for 64-bit IV/UV)
+used to be parsed incorrectly.
+
+=item *
+
 XXX
 
 =back
diff --git a/t/op/hexfp.t b/t/op/hexfp.t
index 8611e0fec39a..5ed03158b447 100644
--- a/t/op/hexfp.t
+++ b/t/op/hexfp.t
@@ -10,7 +10,7 @@ use strict;
 
 use Config;
 
-plan(tests => 125);
+plan(tests => 128);
 
 # Test hexfloat literals.
 
@@ -291,6 +291,41 @@ BEGIN { overload::constant float => sub { return eval $_[0]; }; }
 print 00.1p3;
 CODE
 
+{
+    # First 50 decimal digits (~166 significant bits) of Pi.
+    my $pi = 3.1415926535_8979323846_2643383279_5028841971_6939937510;
+
+    # Number of mantissa (significant) bits including implicit (hidden) bit.
+    my $nv_mant_dig = ($Config{usequadmath} ? 113 :
+                       ($Config{nvmantbits} +
+                        ((($Config{nvtype} eq 'long double' &&
+                           $Config{d_long_double_style_ieee_std}) ||
+                          ($Config{nvtype} eq 'double' &&
+                           $Config{d_double_style_ieee})) ? 1 : 0)));
+
+  SKIP:
+    {
+        skip("NV is not wide enough to hold 50-bit mantissa", 1)
+            unless $nv_mant_dig >= 50;
+        my $a = eval '0x1921fb54442.d18p-39'; # 41+9 bits.
+        within($a, $pi, 1e-15);
+    }
+  SKIP:
+    {
+        skip("NV is not wide enough to hold 64-bit mantissa", 1)
+            unless $nv_mant_dig >= 64;
+        my $a = eval '0xc90fdaa22168c23.5p-58'; # 60+4 bits.
+        within($a, $pi, 1e-19);
+    }
+  SKIP:
+    {
+        skip("NV is not wide enough to hold 110-bit mantissa", 1)
+            unless $nv_mant_dig >= 110;
+        my $a = eval '$a = 0x1921fb54442d18469898cc51701b.8p-107'; # 109+1 bits.
+        within($a, $pi, 1e-33);
+    }
+}
+
 # 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/toke.c b/toke.c
index 4ebb261ffe08..4ed042767cd0 100644
--- a/toke.c
+++ b/toke.c
@@ -12637,6 +12637,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
                          * end just multiply n by the right
                          * amount. */
                         n += (NV) b;
+                        significant_bits += shift;
                     }
 
                     /* this could be hexfp, but peek ahead
@@ -12664,11 +12665,12 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
                  * detection will shortly be more thorough with the
                  * underbar checks. */
                 const char* h = s;
-                significant_bits = (u == 0) ? 0 : msbit_pos(u) + 1;
+                if (u != 0)
+                    significant_bits += msbit_pos(u) + 1;
 #ifdef HEXFP_UQUAD
-                hexfp_uquad = u;
+                hexfp_uquad = overflowed ? (Uquad_t)n : u;
 #else /* HEXFP_NV */
-                hexfp_nv = u;
+                hexfp_nv = overflowed ? n : (NV)u;
 #endif
                 if (*h == '.') {
 #ifdef HEXFP_NV