Fortran: [PR93727] Add EX format READ (read_ex)

From ac5caffca8de75c6ad6026d930c1bc8a38ee0452 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <jvdelisle@gcc.gnu.org>
Date: Mon, 25 May 2026 21:13:19 -0700
Subject: [PATCH] Fortran: [PR93727] Add EX format READ (read_ex)

Implement read_ex in libgfortran to handle EX edit-descriptor input
per Fortran 2023 13.7.2.3.6.  The input field may contain:

  * a hexadecimal-significand form (0X<sig>P<exp>) passed directly
    to the C strtod/strtold family for exact bit-for-bit conversion;
  * any form acceptable for Fw.d input (decimal fallback), including
    INF and NAN representations.

For decimal input without a decimal point the d field of the EX.w.d
descriptor adjusts the exponent exactly as for Fw.d.  BN/BZ blank
handling and the kP scale factor are also supported via the shared
decimal path.

Assisted by: Claude Sonnet 4.6

	PR fortran/93727

libgfortran/ChangeLog:

	* io/read.c (read_ex): New function implementing EX format read.
	* io/io.h (read_ex): Declare.
	* io/transfer.c (formatted_transfer_scalar_read): Add FMT_EX case
	dispatching to read_ex.

gcc/testsuite/ChangeLog:

	* gfortran.dg/EXformat_4.F90: New test covering EX format read
	for kind=4 and 8 (always) and kind=10, 16 (when available):
	hex-significand literals, lowercase prefix, negative binary
	exponent, decimal fallback, d-field adjustment, INF/NAN, zero
	field, and round-trips through write_ex.
---
 gcc/testsuite/gfortran.dg/EXformat_4.F90 | 172 +++++++++++
 libgfortran/io/io.h                      |   3 +
 libgfortran/io/read.c                    | 358 +++++++++++++++++++++++
 libgfortran/io/transfer.c                |   8 +
 4 files changed, 541 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/EXformat_4.F90

diff --git a/gcc/testsuite/gfortran.dg/EXformat_4.F90 b/gcc/testsuite/gfortran.dg/EXformat_4.F90
new file mode 100644
index 00000000000..c90857ac3e7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/EXformat_4.F90
@@ -0,0 +1,172 @@ 
+! { dg-do run }
+! PR93727 Test EX format READ (read_ex).
+! Covers: hex-significand input (0X...P...), decimal fallback, round-trips,
+! INF/NAN, and all supported real kinds.
+program main
+  implicit none
+  call test04
+  call test08
+  call test10
+  call test16
+
+contains
+
+subroutine test04
+  real(kind=4) :: r4
+  character(kind=1,len=40) :: s
+
+  ! Round-trip: write then read back.
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_4)
+  read(s,'(EX40.0)') r4
+  if (r4 /= -huge(1.0_4)) stop 1
+
+  s = ' '
+  write(s,'(EX0.0)') tiny(1.0_4)
+  read(s,'(EX40.0)') r4
+  if (r4 /= tiny(1.0_4)) stop 2
+
+  ! Explicit hex literal input.
+  s = '0X1.8P+0'             ! = 1.5 exactly
+  read(s,'(EX40.0)') r4
+  if (r4 /= 1.5_4) stop 3
+
+  s = '-0X1.P+0'             ! = -1.0
+  read(s,'(EX40.0)') r4
+  if (r4 /= -1.0_4) stop 4
+
+  ! Decimal fallback: no 0X prefix, ordinary E-style input.
+  s = '1.5E0'
+  read(s,'(EX40.0)') r4
+  if (r4 /= 1.5_4) stop 5
+
+  s = '   1.5E2   '
+  read(s,'(EX40.0)') r4
+  if (r4 /= 150.0_4) stop 6
+
+  ! Zero field (blank record).
+  s = '    '
+  read(s,'(EX4.0)') r4
+  if (r4 /= 0.0_4) stop 7
+
+end subroutine test04
+
+
+subroutine test08
+  real(kind=8) :: r8
+  character(kind=1,len=40) :: s
+
+  ! Round-trip.
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_8)
+  read(s,'(EX40.0)') r8
+  if (r8 /= -huge(1.0_8)) stop 8
+
+  s = ' '
+  write(s,'(EX0.0)') tiny(1.0_8)
+  read(s,'(EX40.0)') r8
+  if (r8 /= tiny(1.0_8)) stop 9
+
+  ! Explicit hex: IEEE 754 representation of 1/3.
+  s = '0X1.5555555555555P-2'
+  read(s,'(EX40.0)') r8
+  if (r8 /= 1.0_8 / 3.0_8) stop 10
+
+  ! Negative hex.
+  s = '-0X1.8P+0'            ! = -1.5
+  read(s,'(EX40.0)') r8
+  if (r8 /= -1.5_8) stop 11
+
+  ! Decimal fallback.
+  s = '3.14159265358979E0'
+  read(s,'(EX40.0)') r8
+  if (abs(r8 - 3.14159265358979_8) > 2.0_8 * epsilon(r8)) stop 12
+
+  ! Round-trip on an interesting value.
+  s = ' '
+  write(s,'(EX0.0)') -3.14159265358979_8 * 25.0_8
+  read(s,'(EX40.0)') r8
+  if (r8 /= -3.14159265358979_8 * 25.0_8) stop 13
+
+  ! Lowercase hex prefix and negative binary exponent.
+  s = '0x1.8p-1'            ! = 0.75
+  read(s,'(EX40.0)') r8
+  if (r8 /= 0.75_8) stop 14
+
+  ! d-field: no decimal point in decimal input; d=2 places from right.
+  s = '12345   '
+  read(s,'(EX10.2)') r8
+  if (r8 /= 123.45_8) stop 15
+
+  ! INF and NaN input via decimal fallback path.
+  s = 'Inf'
+  read(s,'(EX40.0)') r8
+  if (r8 <= huge(r8)) stop 16
+
+  s = '-Infinity'
+  read(s,'(EX40.0)') r8
+  if (r8 >= -huge(r8)) stop 17
+
+  s = 'NaN'
+  read(s,'(EX40.0)') r8
+  if (r8 == r8) stop 18
+
+end subroutine test08
+
+
+#ifdef __GFC_REAL_10__
+subroutine test10
+  real(kind=10) :: r10
+  character(kind=1,len=40) :: s
+
+  ! Round-trip.
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_10)
+  read(s,'(EX40.0)') r10
+  if (r10 /= -huge(1.0_10)) stop 19
+
+  s = ' '
+  write(s,'(EX0.0)') tiny(1.0_10)
+  read(s,'(EX40.0)') r10
+  if (r10 /= tiny(1.0_10)) stop 20
+
+  ! Explicit hex: 1.5 = 0X1.8P+0
+  s = '0X1.8P+0'
+  read(s,'(EX40.0)') r10
+  if (r10 /= 1.5_10) stop 21
+
+end subroutine test10
+#else
+subroutine test10
+end subroutine test10
+#endif
+
+
+#ifdef __GFC_REAL_16__
+subroutine test16
+  real(kind=16) :: r16
+  character(kind=1,len=40) :: s
+
+  ! Round-trip.
+  s = ' '
+  write(s,'(EX0.0)') -huge(1.0_16)
+  read(s,'(EX40.0)') r16
+  if (r16 /= -huge(1.0_16)) stop 22
+
+  s = ' '
+  write(s,'(EX0.0)') tiny(1.0_16)
+  read(s,'(EX40.0)') r16
+  if (r16 /= tiny(1.0_16)) stop 23
+
+  ! Explicit hex: 1.5 = 0X1.8P+0
+  s = '0X1.8P+0'
+  read(s,'(EX40.0)') r16
+  if (r16 /= 1.5_16) stop 24
+
+end subroutine test16
+#else
+subroutine test16
+end subroutine test16
+#endif
+
+end program main
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 1fd0908859f..d131d9544c4 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -887,6 +887,9 @@  internal_proto(read_a);
 extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_f);
 
+extern void read_ex (st_parameter_dt *, const fnode *, char *, int);
+internal_proto(read_ex);
+
 extern void read_l (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_l);
 
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index aeec725684b..047fff11643 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -1525,6 +1525,364 @@  bad_float:
 }
 
 
+/* read_ex()-- Read a floating-point number with EX editing.
+   Per Fortran 2023 13.7.2.3.6 para 3, the input form is the same as for
+   Fw.d editing (13.7.2.3.2).  That includes the hexadecimal-significand
+   form (13.7.2.3.2 para 7): [sign] 0X [hex-significand] P [decimal-exp].
+   Decimal mantissas and IEEE exceptional forms (INF, NAN) are also
+   accepted.  Embedded blanks are not permitted within a hex float; C
+   strtod handles the 0x...p... form natively.  */
+
+void
+read_ex (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
+{
+#define READEX_TMP 64
+  char tmp[READEX_TMP];
+  size_t buf_size = 0;
+  size_t w;
+  int seen_dp, exponent;
+  int exponent_sign;
+  const char *p;
+  char *buffer;
+  char *out;
+  int seen_int_digit;
+  int seen_dec_digit;
+
+  seen_dp = 0;
+  seen_int_digit = 0;
+  seen_dec_digit = 0;
+  exponent_sign = 1;
+  exponent = 0;
+  w = f->u.real.w;
+  buffer = tmp;
+
+  p = read_block_form (dtp, &w);
+  if (p == NULL)
+    return;
+  p = eat_leading_spaces (&w, (char *) p);
+  if (w == 0)
+    goto zero;
+
+  buf_size = w + 11;
+  if (buf_size > READEX_TMP)
+    buffer = xmalloc (buf_size);
+
+  out = buffer;
+
+  /* Optional sign.  */
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+	*(out++) = '-';
+      ++p;
+      --w;
+    }
+
+  p = eat_leading_spaces (&w, (char *) p);
+  if (w == 0)
+    {
+      if (buf_size > READEX_TMP)
+	free (buffer);
+      goto zero;
+    }
+
+  /* IEEE exceptional specification: INF or NAN.  */
+  if (unlikely (w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N')))
+    {
+      int seen_paren = 0;
+      char *save = out;
+
+      while (w > 0)
+	{
+	  *out = safe_tolower (*p);
+	  switch (*p)
+	    {
+	    case ' ':
+	      if (dtp->u.p.blank_status == BLANK_ZERO)
+		{
+		  *out = '0';
+		  break;
+		}
+	      *out = '\0';
+	      if (seen_paren == 1)
+		goto bad_float;
+	      break;
+	    case '(':
+	      seen_paren++;
+	      *out = '\0';
+	      break;
+	    case ')':
+	      if (seen_paren++ != 1)
+		goto bad_float;
+	      break;
+	    default:
+	      if (!safe_isalnum (*out))
+		goto bad_float;
+	    }
+	  --w;
+	  ++p;
+	  ++out;
+	}
+
+      *out = '\0';
+
+      if (seen_paren != 0 && seen_paren != 2)
+	goto bad_float;
+
+      if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0))
+	{
+	  if (seen_paren)
+	    goto bad_float;
+	}
+      else if (strcmp (save, "nan") != 0)
+	goto bad_float;
+
+      convert_infnan (dtp, dest, buffer, length);
+      if (buf_size > READEX_TMP)
+	free (buffer);
+      return;
+    }
+
+  /* Hexadecimal-significand number: 0X or 0x prefix.
+     Embedded blanks are forbidden; we stop at the first blank and let
+     convert_real report an error if the string is malformed.  */
+  if (w >= 2 && *p == '0' && (p[1] == 'x' || p[1] == 'X'))
+    {
+      while (w > 0 && *p != ' ')
+	{
+	  *(out++) = *p++;
+	  --w;
+	}
+      *(out++) = '\0';
+
+      convert_real (dtp, dest, buffer, length);
+      if (buf_size > READEX_TMP)
+	free (buffer);
+      return;
+    }
+
+  /* Decimal floating-point fallback: same rules as Fw.d editing.  */
+  while (w > 0)
+    {
+      switch (*p)
+	{
+	case ',':
+	  if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
+	    goto bad_float;
+	  if (seen_dp)
+	    goto bad_float;
+	  if (!seen_int_digit)
+	    *(out++) = '0';
+	  *(out++) = '.';
+	  seen_dp = 1;
+	  break;
+
+	case '.':
+	  if (dtp->u.p.current_unit->decimal_status != DECIMAL_POINT)
+	    goto bad_float;
+	  if (seen_dp)
+	    goto bad_float;
+	  if (!seen_int_digit)
+	    *(out++) = '0';
+	  *(out++) = '.';
+	  seen_dp = 1;
+	  break;
+
+	case ' ':
+	  if (dtp->u.p.blank_status == BLANK_ZERO)
+	    {
+	      *(out++) = '0';
+	      goto found_digit;
+	    }
+	  else if (dtp->u.p.blank_status == BLANK_NULL)
+	    break;
+	  else
+	    goto done;
+	  /* Fall through.  */
+	case '0':
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	  *(out++) = *p;
+found_digit:
+	  if (!seen_dp)
+	    seen_int_digit = 1;
+	  else
+	    seen_dec_digit = 1;
+	  break;
+
+	case '-':
+	case '+':
+	  goto exponent;
+
+	case 'e':
+	case 'E':
+	case 'd':
+	case 'D':
+	case 'q':
+	case 'Q':
+	  ++p;
+	  --w;
+	  goto exponent;
+
+	default:
+	  goto bad_float;
+	}
+
+      ++p;
+      --w;
+    }
+
+  /* No exponent seen; apply the scale factor.  */
+  exponent = -dtp->u.p.scale_factor;
+  goto done;
+
+exponent:
+  p = eat_leading_spaces (&w, (char *) p);
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+	exponent_sign = -1;
+      ++p;
+      --w;
+    }
+
+  if (w == 0)
+    {
+      if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+	goto done;
+      else
+	goto bad_float;
+    }
+
+  if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+    {
+      while (w > 0 && safe_isdigit (*p))
+	{
+	  exponent *= 10;
+	  exponent += *p - '0';
+	  ++p;
+	  --w;
+	}
+      while (w > 0)
+	{
+	  if (*p != ' ')
+	    goto bad_float;
+	  ++p;
+	  --w;
+	}
+    }
+  else
+    {
+      while (w > 0)
+	{
+	  if (*p == ' ')
+	    {
+	      if (dtp->u.p.blank_status == BLANK_ZERO)
+		exponent *= 10;
+	      else
+		assert (dtp->u.p.blank_status == BLANK_NULL);
+	    }
+	  else if (!safe_isdigit (*p))
+	    goto bad_float;
+	  else
+	    {
+	      exponent *= 10;
+	      exponent += *p - '0';
+	    }
+	  ++p;
+	  --w;
+	}
+    }
+
+  exponent *= exponent_sign;
+
+done:
+  if (!seen_dp)
+    exponent -= f->u.real.d;
+
+  if (seen_dp && !seen_dec_digit)
+    *(out++) = '0';
+  else if (!seen_int_digit && !seen_dec_digit)
+    {
+      notify_std (&dtp->common, GFC_STD_LEGACY,
+		  "REAL input of style 'E+NN'");
+      *(out++) = '0';
+    }
+
+  if (exponent != 0)
+    {
+      int dig;
+
+      *(out++) = 'e';
+      if (exponent < 0)
+	{
+	  *(out++) = '-';
+	  exponent = -exponent;
+	}
+
+      if (exponent >= 10000)
+	goto bad_float;
+
+      for (dig = 3; dig >= 0; --dig)
+	{
+	  out[dig] = (char) ('0' + exponent % 10);
+	  exponent /= 10;
+	}
+      out += 4;
+    }
+  *(out++) = '\0';
+
+  convert_real (dtp, dest, buffer, length);
+  if (buf_size > READEX_TMP)
+    free (buffer);
+  return;
+
+zero:
+  switch (length)
+    {
+    case 4:
+      *((GFC_REAL_4 *) dest) = 0.0;
+      break;
+    case 8:
+      *((GFC_REAL_8 *) dest) = 0.0;
+      break;
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      *((GFC_REAL_10 *) dest) = 0.0;
+      break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+      *((GFC_REAL_16 *) dest) = 0.0;
+      break;
+#endif
+#ifdef HAVE_GFC_REAL_17
+    case 17:
+      *((GFC_REAL_17 *) dest) = 0.0;
+      break;
+#endif
+    default:
+      internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+  return;
+
+bad_float:
+  if (buf_size > READEX_TMP)
+    free (buffer);
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		  "Bad value during floating point read");
+  next_record (dtp, 1);
+  return;
+}
+
+
 /* read_x()-- Deal with the X/TR descriptor.  We just read some data
    and never look at it. */
 
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 99e90f3c803..49b211ba667 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1840,6 +1840,14 @@  formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 	  read_f (dtp, f, p, kind);
 	  break;
 
+	case FMT_EX:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_ex (dtp, f, p, kind);
+	  break;
+
 	case FMT_F:
 	  if (n == 0)
 	    goto need_read_data;
-- 
2.54.0