[gcc r17-2529] fortran: Implement list directed read of hex float formats.

https://gcc.gnu.org/g:73e6f2de0e606bf312377ac2dafec3bbf095241a

commit r17-2529-g73e6f2de0e606bf312377ac2dafec3bbf095241a
Author: Jerry DeLisle <[email protected]>
Date:   Wed Jul 15 20:29:38 2026 -0700

    fortran: Implement list directed read of hex float formats.
    
            PR libfortran/93727
    
    libgfortran/ChangeLog:
    
            * io/list_read.c (parse_real): Parse the possible hexadecimal
            float formatted and then allow the convert_real function to
            validate the result.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/EXformat_5.F90: New test.

Diff:
---
 gcc/testsuite/gfortran.dg/EXformat_5.F90 | 131 +++++++++++++++++++++++++++++++
 libgfortran/io/list_read.c               |  85 ++++++++++++++++++++
 2 files changed, 216 insertions(+)

diff --git a/gcc/testsuite/gfortran.dg/EXformat_5.F90 b/gcc/testsuite/gfortran.dg/EXformat_5.F90
new file mode 100644
index 000000000000..cfd699dd6412
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/EXformat_5.F90
@@ -0,0 +1,131 @@
+! { dg-do run }
+! PR93727 Test hex float for list-directed READ.
+
+program main
+  implicit none
+  call test04
+  call test08
+  call test10
+  call test16
+
+contains
+
+subroutine test04
+  real(4) :: r4, a, b
+  real(4) :: arr(3)
+  complex(4) :: z
+  character(len=64) :: s
+
+  ! Round-trip
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_4)
+  read(s,*) r4
+  if (r4 /= -huge(1.0_4)) stop 1
+
+  s = '0X1.8P+0'                ! = 1.5
+  read(s,*) r4
+  if (r4 /= 1.5_4) stop 2
+
+  s = '-0X1.P+0'                ! = -1.0
+  read(s,*) r4
+  if (r4 /= -1.0_4) stop 3
+
+  ! Lowercase
+  s = '0x1.8p-1'                ! = 0.75
+  read(s,*) r4
+  if (r4 /= 0.75_4) stop 4
+
+  ! Hex digit 'E' is not an exponent.
+  s = '0X1.EP+3'                ! (1 + 14/16) * 8 = 15.0
+  read(s,*) r4
+  if (r4 /= 15.0_4) stop 5
+
+  ! Comma-separated list of hex values.
+  s = '0X1P0, 0X1.8P+1'
+  read(s,*) a, b
+  if (a /= 1.0_4 .or. b /= 3.0_4) stop 6
+
+  ! Using a repeat count
+  s = '3*0X1P+1'
+  read(s,*) arr
+  if (any(arr /= 2.0_4)) stop 7
+
+  ! Complex constant with hex real and imaginary parts.
+  s = '(0X1P0, 0X1.8P+1)'
+  read(s,*) z
+  if (z /= (1.0_4, 3.0_4)) stop 8
+end subroutine test04
+
+
+subroutine test08
+  real(8) :: r8, nx
+  character(len=64) :: s
+  namelist /nl8/ nx
+
+  ! Round-trip.
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_8)
+  read(s,*) r8
+  if (r8 /= -huge(1.0_8)) stop 10
+
+  ! Explicit hex: IEEE 754 representation of 1/3.
+  s = '0X1.5555555555555P-2'
+  read(s,*) r8
+  if (r8 /= 1.0_8 / 3.0_8) stop 11
+
+  ! pi, double precision.
+  s = '0X1.921FB54442D18P+1'
+  read(s,*) r8
+  if (abs(r8 - acos(-1.0_8)) > 2.0_8 * epsilon(r8)) stop 12
+
+  ! Hex value inside a NAMELIST.
+  nx = -999.0_8
+  s = '&nl8 nx=0X1.8P+3 /'
+  read(s,nml=nl8)
+  if (nx /= 12.0_8) stop 13
+
+end subroutine test08
+
+
+#ifdef __GFC_REAL_10__
+subroutine test10
+  real(10) :: r10
+  character(len=64) :: s
+
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_10)
+  read(s,*) r10
+  if (r10 /= -huge(1.0_10)) stop 14
+
+  s = '0X1.8P+0'
+  read(s,*) r10
+  if (r10 /= 1.5_10) stop 15
+
+end subroutine test10
+#else
+subroutine test10
+end subroutine test10
+#endif
+
+
+#ifdef __GFC_REAL_16__
+subroutine test16
+  real(16) :: r16
+  character(len=64) :: s
+
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_16)
+  read(s,*) r16
+  if (r16 /= -huge(1.0_16)) stop 16
+
+  s = '0X1.8P+0'
+  read(s,*) r16
+  if (r16 /= 1.5_16) stop 17
+
+end subroutine test16
+#else
+subroutine test16
+end subroutine test16
+#endif
+
+end program main
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 2b577baa7d3c..f2179e2a1d89 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -1539,6 +1539,17 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 
   seen_dp = (c == '.') ? 1 : 0;
 
+  if (c == '0')
+    {
+      int c2 = next_char (dtp);
+      if (c2 == 'x' || c2 == 'X')
+	{
+	  push_char (dtp, c2);
+	  goto hex_real;
+	}
+      unget_char (dtp, c2);
+    }
+
   for (;;)
     {
       if ((c = next_char (dtp)) == EOF)
@@ -1644,6 +1655,30 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 	}
     }
 
+  /* Hexadecimal format so collect the remaining characters.
+     The convert_real will validate it.  */
+ hex_real:
+  for (;;)
+    {
+      if ((c = next_char (dtp)) == EOF)
+	goto bad;
+      switch (c)
+	{
+	case '!':
+	  if (!dtp->u.p.namelist_mode)
+	    goto bad;
+	  /* Fall through.  */
+
+	CASE_SEPARATORS:
+	case ')':
+	  goto done;
+
+	default:
+	  push_char (dtp, c);
+	  break;
+	}
+    }
+
  done:
   unget_char (dtp, c);
   push_char (dtp, '\0');
@@ -1878,6 +1913,17 @@ next:
   switch (c)
     {
     CASE_DIGITS:
+      if (c == '0')
+	{
+	  int c2 = next_char (dtp);
+	  if (c2 == 'x' || c2 == 'X')
+	    {
+	      push_char (dtp, c);
+	      push_char (dtp, c2);
+	      goto hex_real;
+	    }
+	  unget_char (dtp, c2);
+	}
       push_char (dtp, c);
       break;
 
@@ -2018,6 +2064,17 @@ next:
 
   push_char (dtp, c);
 
+  if (c == '0')
+    {
+      int c2 = next_char (dtp);
+      if (c2 == 'x' || c2 == 'X')
+	{
+	  push_char (dtp, c2);
+	  goto hex_real;
+	}
+      unget_char (dtp, c2);
+    }
+
  real_loop:
   for (;;)
     {
@@ -2117,6 +2174,34 @@ next:
 	}
     }
 
+  /* Hexadecimal-significand form: [sign] 0X hex-significand P
+     decimal-exp (F2023 13.7.2.3.2 para 7), also accepted on list-directed
+     input per the same rules as Fw.d editing.  The '0X'/'0x' prefix has
+     already been pushed; collect the remaining characters (hex digits,
+     radix point, P/p exponent letter, exponent sign) verbatim up to the
+     next separator and let convert_real/strtod validate and parse the
+     whole thing, just as read_ex does for formatted EX input.  */
+ hex_real:
+  for (;;)
+    {
+      c = next_char (dtp);
+      switch (c)
+	{
+	case '!':
+	  if (!dtp->u.p.namelist_mode)
+	    goto bad_real;
+	  /* Fall through.  */
+
+	CASE_SEPARATORS:
+	case EOF:
+	  goto done;
+
+	default:
+	  push_char (dtp, c);
+	  break;
+	}
+    }
+
  done:
   unget_char (dtp, c);
   eat_separator (dtp);