[patch] PR93727 Fortran 2018: EX edit descriptor

commit 051211082b5653cf8d52c60b249f1c69f6025103
Author: Jerry DeLisle <[email protected]>
Date:   Thu Jan 29 11:07:22 2026 -0800

    Fortran: Implement EX format writing of floats
    
    This patch implements the Fortran 2018 Standard EX formatting for
    WRITE of floating point.  KIND=16 is not implemented by this. READ
    is not implemented.
    
            PR fortran/93727
    
    gcc/fortran/ChangeLog:
    
            * io.cc (enum format_token): Add FMT_EX token.
            (format_lex): Add parsing for the FMT_EX and add
            checks as needed.
    
    libgfortran/ChangeLog:
    
            * io/format.c (format_lex): Add use of FMT_EX.
            (parse_format_list): Add parsing of FMT_EX.
            (next_format): Use FMT_EX in reversion check.
            * io/io.h (write_ex): Add prototype for write_ex.
            (internal_proto): Make it internal.
            * io/transfer.c (formatted_transfer_scalar_write): Use
            FMT_EX token in the main loop processing.
            * io/write.c (write_default_char4): Cleanup whitespace.
            (write_a): Likewise.
            (write_boz): Likewise.
            (write_decimal): Likewise.
            (otoa_big): Likewise.
            (write_character): Likewise.
            (write_float_0): Likewise.
            (write_ex): New function that implements the hex float write,
            padding with spaces as needed. Handles kind=1 and kind=4
            character output. Uses the new function get_float_hex_string ()
            defined in io/write_float.def.
            (write_real): Cleanup whitespace.
            (write_complex): Likewise.
            (nml_write_obj): Likewise.
            (namelist_write): Likewise.
            * io/write_float.def (get_float_hex_string): New function that uses the
            snprintf() function with %A to create the initial hex formmatted float
            string for later re-formatting in the write_ex function.
            (build_float_string): Cleanup whitespace.
            (quadmath_snprintf): Likewise.
            (determine_en_precision): Likewise.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/EXformat_1.f90: New test.
            * gfortran.dg/EXformat_2.f90: New test.

diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc
index 5bffed22eb8..2c5a58d4903 100644
--- a/gcc/fortran/io.cc
+++ b/gcc/fortran/io.cc
@@ -118,11 +118,11 @@ static gfc_dt *current_dt;
 enum format_token
 {
   FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
-  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
-  FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
-  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
-  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
-  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, FMT_RPAREN, FMT_X,
+  FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, FMT_E, FMT_EN, FMT_ES,
+  FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC, FMT_DP, FMT_T,
+  FMT_TR, FMT_TL, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ,
+  FMT_DT, FMT_EX, FMT_LPS, FMT_LPZ, FMT_LZ
 };
 
 /* Local variables for checking format strings.  The saved_token is
@@ -422,6 +422,8 @@ format_lex (void)
 	token = FMT_EN;
       else if (c == 'S')
         token = FMT_ES;
+      else if (c == 'X')
+	token = FMT_EX;
       else
 	{
 	  token = FMT_E;
@@ -439,6 +441,35 @@ format_lex (void)
       break;
 
     case 'L':
+      c = next_char_not_space ();
+      switch (c)
+	{
+	case 'P':
+	  c = next_char_not_space ();
+	  switch (c)
+	  {
+	    case 'S':
+	      token = FMT_LPS;
+	      break;
+
+	    case 'Z':
+	      token = FMT_LPZ;
+	      break;
+
+	    default:
+	      token = FMT_UNKNOWN;
+	      unget_char ();
+	      break;
+	  }
+	case 'Z':
+	  token = FMT_LZ;
+	  break;
+
+	default:
+	  token = FMT_UNKNOWN;
+	  unget_char ();
+	  break;
+	}
       token = FMT_L;
       break;
 
@@ -746,6 +777,7 @@ format_item_1:
     case FMT_E:
     case FMT_EN:
     case FMT_ES:
+    case FMT_EX:
     case FMT_G:
     case FMT_L:
     case FMT_A:
@@ -879,6 +911,7 @@ data_desc:
 
     case FMT_D:
     case FMT_E:
+    case FMT_EX:
     case FMT_G:
     case FMT_EN:
     case FMT_ES:
diff --git a/gcc/testsuite/gfortran.dg/EXformat_1.f90 b/gcc/testsuite/gfortran.dg/EXformat_1.f90
new file mode 100644
index 00000000000..0725cf1d34e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/EXformat_1.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! pr93727 EX Format Specifiers, testing various kinds, default field widths
+program main
+  implicit none
+  character(kind=1, len=15) :: s1  
+  real(4) :: r4
+  real(8) :: r8
+  real(10) :: r10
+  !real(16) :: r16  
+  r4 = -huge(1.0_4/3.0_4)
+  r8 = -huge( 1.0_8/3.0_8)
+  r10= -huge(1.0_10/3.0_10)
+  !r16 = 1.0_16/3.0_16
+  
+  write(s1,"(EX0.0,'<')") r4
+  if (s1.ne."-0X1.P+127<") stop 1
+  write(s1,"(EX0.0,'<')") r8
+  if (s1.ne."-0X1.P+1023<") stop 2
+  write(s1,"(EX0.0,'<')") r10
+  if (s1.ne."-0XF.P+16380<") stop 3
+
+  write(s1,"(EX0.0,'<')") 1.0_4/r4
+  if (s1.ne."-0X1P-128<") stop 4
+  write(s1,"(EX0.0,'<')") 1.0_8/r8
+  if (s1.ne."-0X0.P-1022<") stop 5
+  write(s1,"(EX0.0,'<')") 1.0_10/r10
+  if (s1.ne."-0X2P-16385<") stop 6
+  !write(*,"(EX0.0,'<')" r16
+end program main
diff --git a/gcc/testsuite/gfortran.dg/EXformat_2.f90 b/gcc/testsuite/gfortran.dg/EXformat_2.f90
new file mode 100644
index 00000000000..f00b3d2f4a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/EXformat_2.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+! PR93727 Test writing EX as character(kind=1) output
+program kind1
+  implicit none
+  integer, parameter :: wp = 8
+  real(kind=wp) :: num
+  character(kind=1,len=35) :: str1
+  
+  num = -3.14159682678_wp * 25._wp
+  write(str1, '(">",EX30.0,"<")') num
+  if (str1.ne.">                      -0X1.P+6<") stop 1
+  write(str1, '(">",EX30.1,"<")') num
+  if (str1.ne.">                     -0X1.3P+6<") stop 2
+  write(str1, '(">",EX30.2,"<")') num
+  if (str1.ne.">                    -0X1.3AP+6<") stop 3
+  write(str1, '(">",EX30.3,"<")') num
+  if (str1.ne.">                   -0X1.3A2P+6<") stop 4
+  write(str1, '(">",EX30.4,"<")') num
+  if (str1.ne.">                  -0X1.3A28P+6<") stop 5
+  write(str1, '(">",EX30.15e8,"<")') num
+  if (str1.ne.">  -0X1.3A28E0F6C7BF600P+000006<") stop 6
+  write(str1, '(">",EX8.5,"<")') num
+  if (str1.ne.">********<") stop 7
+end program kind1
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 2b3ee0b2fbf..4d5fb53760b 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -522,6 +522,9 @@ format_lex (format_data *fmt)
 	case 'S':
 	  token = FMT_ES;
 	  break;
+	case 'X':
+	  token = FMT_EX;
+	  break;
 	default:
 	  token = FMT_E;
 	  unget_char (fmt);
@@ -706,7 +709,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
       tail->repeat = 1;
 
       t = format_lex (fmt);
-      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
+      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_EX || t == FMT_D
 	  || t == FMT_G || t == FMT_E)
 	{
 	  repeat = 1;
@@ -818,6 +821,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
     case FMT_E:
     case FMT_EN:
     case FMT_ES:
+    case FMT_EX:
     case FMT_D:
     case FMT_DT:
     case FMT_L:
@@ -921,6 +925,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
     case FMT_G:
     case FMT_EN:
     case FMT_ES:
+    case FMT_EX:
       *seen_dd = true;
       get_fnode (fmt, &head, &tail, t);
       tail->repeat = repeat;
@@ -1538,8 +1543,8 @@ next_format (st_parameter_dt *dtp)
 
   if (!fmt->reversion_ok &&
       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
-       t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
-       t == FMT_A || t == FMT_D || t == FMT_DT))
+       t == FMT_E || t == FMT_EN || t == FMT_ES || t== FMT_EX || t == FMT_G ||
+       t == FMT_L || t == FMT_A || t == FMT_D || t == FMT_DT))
     fmt->reversion_ok = 1;
   return f;
 }
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 7928c196f63..285003b4dad 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -145,7 +145,8 @@ typedef enum
   FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
   FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
   FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
-  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
+  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT, FMT_EX,
+  FMT_LPS, FMT_LPZ, FMT_LZ
 }
 format_token;
 
@@ -946,6 +947,9 @@ internal_proto(write_en);
 extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_es);
 
+extern void write_ex (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_es);
+
 extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_f);
 
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 7e6795e70f7..b6b60db973c 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2129,7 +2129,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 		    || t == FMT_Z  || t == FMT_F  || t == FMT_E
 		    || t == FMT_EN || t == FMT_ES || t == FMT_G
 		    || t == FMT_L  || t == FMT_A  || t == FMT_D
-		    || t == FMT_DT))
+		    || t == FMT_DT || t == FMT_EX))
 	    || t == FMT_STRING))
 	{
 	  if (dtp->u.p.skips > 0)
@@ -2351,6 +2351,15 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	    write_es (dtp, f, p, kind);
 	  break;
 
+	case FMT_EX:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  write_ex (dtp, f, p, kind);
+	  break;
+
+
 	case FMT_F:
 	  if (n == 0)
 	    goto need_data;
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index a5e89c64951..f7993cc037c 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include "unix.h"
 #include <assert.h>
 #include <string.h>
+#include "config.h"
 
 #define star_fill(p, n) memset(p, '*', n)
 
@@ -127,7 +128,7 @@ write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
 		return;
 	      *p++ = (uchar) c;
 	    }
-          else
+	  else
 	    {
 	      p = write_block (dtp, 1);
 	      if (p == NULL)
@@ -409,8 +410,8 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
 	      /* Write out the CR_LF sequence.  */
 	      q++;
 	      p = write_block (dtp, 2);
-              if (p == NULL)
-                return;
+	      if (p == NULL)
+		return;
 	      memcpy (p, crlf, 2);
 	    }
 	  else
@@ -709,11 +710,11 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
   if (m == 0 && n == 0)
     {
       if (w == 0)
-        w = 1;
+	w = 1;
 
       p = write_block (dtp, w);
       if (p == NULL)
-        return;
+	return;
       if (unlikely (is_char4_unit (dtp)))
 	{
 	  gfc_char4_t *p4 = (gfc_char4_t *) p;
@@ -825,11 +826,11 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
   if (m == 0 && n == 0)
     {
       if (w == 0)
-        w = 1;
+	w = 1;
 
       p = write_block (dtp, w);
       if (p == NULL)
-        return;
+	return;
       if (unlikely (is_char4_unit (dtp)))
 	{
 	  gfc_char4_t *p4 = (gfc_char4_t *) p;
@@ -1250,7 +1251,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
 	      octet |= (c & 1) << j;
 	      c >>= 1;
 	      if (++k > 7)
-	        {
+		{
 		  i++;
 		  k = 0;
 		  c = *--p;
@@ -1275,7 +1276,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
 	      octet |= (c & 1) << j;
 	      c >>= 1;
 	      if (++k > 7)
-	        {
+		{
 		  i++;
 		  k = 0;
 		  c = *++p;
@@ -1661,9 +1662,9 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, size_t leng
 	  *p++ = d;
 
 	  for (size_t i = 0; i < length; i++)
-            {
-              *p++ = source[i];
-              if (source[i] == d)
+	    {
+	      *p++ = source[i];
+	      if (source[i] == d)
 		*p++ = d;
 	    }
 
@@ -1812,7 +1813,7 @@ write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kin
   buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
 
   get_float_string (dtp, f, source , kind, 0, buffer,
-                           precision, buf_size, result, &flt_str_len);
+			   precision, buf_size, result, &flt_str_len);
   write_float_string (dtp, result, flt_str_len);
 
   if (buf_size > BUF_STACK_SZ)
@@ -1855,6 +1856,191 @@ write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
   write_float_0 (dtp, f, p, len);
 }
 
+void
+write_ex (st_parameter_dt *dtp, const fnode *f, const char *p, int kind)
+{
+  /* The EX specifier in Fortran 2018 produces hexadecimal floating-point
+     output similar to C's %a format. The format is EXw.dEe where:
+     - w is the total field width
+     - d is the number of significant hex digits after the radix point
+     - e is the width of the exponent field (including 'p' and sign)
+
+     Example output: 0x1.23p+10 or -0x1.abcp-5 */
+
+  char buf[64];
+  char output[64];
+  char *p_pos, *exp_pos, *decimal;
+  char sign_char;
+  int w, d, e, result, res_len;
+  int exp_value;
+  int mantissa_digits;
+  size_t output_len, mantissa_len, i, copy_len;
+
+  if (kind == 16)
+    {
+      generate_error (&dtp->common, LIBERROR_FORMAT,
+		      "Sorry, EX format not implemented for KIND=16");
+      return;
+    }
+
+  /* Get the user supplied width parameters.  */
+
+  w = f->u.real.w;  /* Total field width */
+  d = f->u.real.d;  /* Significant hex digits after decimal */
+  e = f->u.real.e == -1 ? 0 : f->u.real.e; /* Exponent field width */
+
+  /* If d == 0 then set it to a default value depending on the kind:
+
+      kind=4,  set d=6
+      kind=8,  set d=13
+      kind=10, set d=15  */
+
+  /* Get the hex float string using uppercase format (e.g., 0X1.23P+10) */
+  result = get_float_hex_string (p, kind, buf, &res_len);
+
+  if (result < 0)
+    {
+      /* Error - output asterisks  */
+      w = (w > 0) ? w : 1;
+      char *out = write_block (dtp, w);
+      if (out != NULL)
+	memset (out, '*', w);
+      return;
+    }
+
+  /* Find the exponent marker 'P' (uppercase from %A format) */
+  p_pos = strchr (buf, 'P');
+  if (p_pos == NULL)
+    {
+      /* No exponent found - this occurs when the value is INF or NAN  */
+      strncpy (output, buf, sizeof (output) - 1);
+      output[sizeof (output) - 1] = '\0';
+      output_len = strlen (output);
+      goto write_output;
+    }
+
+  /* Parse exponent value THIS is probably overkill  */
+  exp_pos = p_pos + 1;
+  sign_char = '+';
+  if (*exp_pos == '+' || *exp_pos == '-')
+    {
+      sign_char = *exp_pos;
+      exp_pos++;
+    }
+
+  if (sscanf (exp_pos, "%d", &exp_value) != 1)
+    {
+      /* Failed to parse - use original */
+      strncpy (output, buf, sizeof (output) - 1);
+      output[sizeof (output) - 1] = '\0';
+      output_len = strlen (output);
+      goto write_output;
+    }
+
+  /* Handle the 'd' parameter - adjust mantissa precision if specified */
+  if (d >= 0)
+    {
+      /* Find the decimal point in mantissa */
+      decimal = strchr (buf, '.');
+      if (decimal != NULL && decimal < p_pos)
+	{
+	  /* Count current mantissa digits after decimal point */
+	  mantissa_digits = p_pos - decimal - 1;
+
+	  /* Adjust mantissa to have exactly 'd' digits after decimal */
+	  if (d < mantissa_digits)
+	    {
+	      /* Truncate mantissa */
+	      memmove (decimal + d + 1, p_pos, strlen (p_pos) + 1);
+	      p_pos = decimal + d + 1;
+	    }
+	  else if (d > mantissa_digits)
+	    {
+	      /* Pad with zeros - shift exponent part right */
+	      int pad_count = d - mantissa_digits;
+	      if (strlen (buf) + pad_count < sizeof (buf))
+		{
+		  memmove (p_pos + pad_count, p_pos, strlen (p_pos) + 1);
+		  memset (p_pos, '0', pad_count);
+		  p_pos += pad_count;
+		}
+	    }
+	}
+    }
+
+  /* Format the exponent field with specified width 'e'. The 'e' parameter
+     is the total exponent width INCLUDING 'P' and the sign.  */
+
+  int exp_digits = e - 2;  /* Subtract 'P' and sign character */
+  if (exp_digits < 1)
+    exp_digits = 1;  /* Minimum 1 digit */
+
+  /* Construct output with formatted exponent */
+  mantissa_len = p_pos - buf;
+  if (mantissa_len >= sizeof (output))
+    mantissa_len = sizeof (output) - 1;
+
+  memcpy (output, buf, mantissa_len);
+  snprintf (output + mantissa_len, sizeof (output) - mantissa_len,
+	    "P%c%0*d", sign_char, exp_digits, abs (exp_value));
+
+  output_len = strlen (output);
+
+  /* Check the field width 'w' if specified. If the field width is not
+     wide enough, fill it with  "*"  before writing it out.  */
+  if (w > 0 && (output_len > (size_t) w))
+    {
+      char *out = write_block (dtp, w);
+      if (unlikely (is_char4_unit (dtp)))
+	{
+	  gfc_char4_t *out4 = (gfc_char4_t *) out;
+	  for (i = 0; i < (size_t)w; i++)
+	    out4[i] = (gfc_char4_t) '*';
+	}
+      else
+	{
+	  if (out != NULL)
+	    memset (out, '*', w);
+	}
+      return;
+    }
+
+write_output:
+
+  /* Determine actual output width */
+  int actual_width = (w > 0) ? w : (int) output_len;
+
+  /* Get the block of memory that will be transferred out.  */
+  char *out = write_block (dtp, actual_width);
+  if (out == NULL)
+    return;
+
+  /* Handle character unit type (4-byte vs 1-byte) */
+  if (unlikely (is_char4_unit (dtp)))
+    {
+      gfc_char4_t *out4 = (gfc_char4_t *) out;
+
+      /* Pad with spaces if width specified and we're short */
+      int pad_len = actual_width - output_len;
+      if (pad_len > 0)
+	memset4 (out4, ' ', pad_len);
+
+      /* Copy out the wide character string.  */
+      out4 += (actual_width - output_len);
+      memcpy4 (out4, output, output_len);
+    }
+  else
+    {
+      /* Pad with spaces if width specified and we're short */
+      if (w > 0 && output_len < (size_t)actual_width)
+	memset (out, ' ', actual_width - output_len);
+      out += (actual_width - output_len);
+
+      /* Copy output string */
+      copy_len = (output_len < (size_t)actual_width) ? output_len : (size_t)actual_width;
+      memcpy (out, output, copy_len);
+    }
+}
 
 /* Set an fnode to default format.  */
 
@@ -1938,7 +2124,7 @@ write_real (st_parameter_dt *dtp, const char *source, int kind)
   buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
 
   get_float_string (dtp, &f, source , kind, 1, buffer,
-                           precision, buf_size, result, &flt_str_len);
+			   precision, buf_size, result, &flt_str_len);
   write_float_string (dtp, result, flt_str_len);
 
   dtp->u.p.scale_factor = orig_scale;
@@ -2046,9 +2232,9 @@ write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
   buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
 
   get_float_string (dtp, &f, source , kind, 0, buffer,
-                           precision, buf_size, result1, &flt_str_len1);
+			   precision, buf_size, result1, &flt_str_len1);
   get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
-                           precision, buf_size, result2, &flt_str_len2);
+			   precision, buf_size, result2, &flt_str_len2);
   if (!dtp->u.p.namelist_mode)
     {
       lblanks = width - flt_str_len1 - flt_str_len2 - 3;
@@ -2344,10 +2530,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
 	  len = strlen (base->var_name);
 	  base_name_len = strlen (base_name);
 	  for (dim_i = 0; dim_i < base_name_len; dim_i++)
-            {
+	    {
 	      cup = safe_toupper (base_name[dim_i]);
 	      write_character (dtp, &cup, 1, 1, NODELIM);
-            }
+	    }
 	}
       clen = strlen (obj->var_name);
       for (dim_i = len; dim_i < clen; dim_i++)
@@ -2440,28 +2626,28 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
 
 	    case BT_INTEGER:
 	      write_integer (dtp, p, len);
-              break;
+	      break;
 
 	    case BT_LOGICAL:
 	      write_logical (dtp, p, len);
-              break;
+	      break;
 
 	    case BT_CHARACTER:
 	      if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
 		write_character (dtp, p, 4, obj->string_length, DELIM);
 	      else
 		write_character (dtp, p, 1, obj->string_length, DELIM);
-              break;
+	      break;
 
 	    case BT_REAL:
 	      write_real (dtp, p, len);
-              break;
+	      break;
 
 	   case BT_COMPLEX:
 	      dtp->u.p.no_leading_blank = 0;
 	      num++;
-              write_complex (dtp, p, len, obj_size);
-              break;
+	      write_complex (dtp, p, len, obj_size);
+	      break;
 
 	    case BT_DERIVED:
 	    case BT_CLASS:
@@ -2603,9 +2789,9 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
 	      free (ext_name);
 	      goto obj_loop;
 
-            default:
+	    default:
 	      internal_error (&dtp->common, "Bad type for namelist write");
-            }
+	    }
 
 	  /* Reset the leading blank suppression, write a comma (or semi-colon)
 	     and, if 5 values have been output, write a newline and advance
@@ -2670,7 +2856,7 @@ namelist_write (st_parameter_dt *dtp)
   switch (dtp->u.p.current_unit->delim_status)
     {
       case DELIM_APOSTROPHE:
-        dtp->u.p.nml_delim = '\'';
+	dtp->u.p.nml_delim = '\'';
 	break;
       case DELIM_QUOTE:
       case DELIM_UNSPECIFIED:
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index 8732df49b28..6782e95adfb 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -26,6 +26,41 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 #include "config.h"
 
+/* Helper function for EX format specifier.
+
+   Returns 0 on success, -1 on error. Fills 'buffer' with the hexadecimal
+   floating-point representation of the input value (using C's %A family).
+   Sets '*res_len' to the length of the string (excluding NUL terminator).
+   Buffer must be at least 64 bytes for safety across all kinds.  */
+static int
+get_float_hex_string (const void *source, int kind, char *buffer,
+		      int *res_len)
+{
+  int result = -1;
+  *res_len = 0;
+
+  switch (kind)
+    {
+    case 4:
+      result = snprintf (buffer, 17, "%A", *(const GFC_REAL_4 *) source);
+      break;
+    case 8:
+      result = snprintf (buffer, 25, "%lA", *(const GFC_REAL_8 *) source);
+      break;
+    case 10:
+      result = snprintf (buffer, 28, "%LA", *(const GFC_REAL_10 *) source);
+      break;
+    case 16:
+    default:
+      return -1;
+    }
+  if (result < 0 )
+    return -1;
+
+  *res_len = (size_t) result;
+  return 0;
+}
+
 typedef enum
 { S_NONE, S_MINUS, S_PLUS }
 sign_t;
@@ -186,7 +221,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
     case FMT_F:
       nbefore = ndigits - precision;
       if ((w > 0) && (nbefore > (int) size))
-        {
+	{
 	  *len = w;
 	  star_fill (result, w);
 	  result[w] = '\0';
@@ -310,7 +345,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
       /* The exponent must be a multiple of three, with 1-3 digits before
 	 the decimal point.  */
       if (!zero_flag)
-        e--;
+	e--;
       if (e >= 0)
 	nbefore = e % 3;
       else
@@ -328,7 +363,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
 
     case FMT_ES:
       if (!zero_flag)
-        e--;
+	e--;
       nbefore = 1;
       nzero = 0;
       nafter = d;
@@ -444,9 +479,9 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
 	  if (i < 0)
 	    {
 	      /* The carry overflowed.  Fortunately we have some spare
-	         space at the start of the buffer.  We may discard some
-	         digits, but this is ok because we already know they are
-	         zero.  */
+		 space at the start of the buffer.  We may discard some
+		 digits, but this is ok because we already know they are
+		 zero.  */
 	      digits--;
 	      digits[0] = '1';
 	      if (ft == FMT_F)
@@ -562,7 +597,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
       /* The output is zero, so set the sign according to the sign bit unless
 	 -fno-sign-zero was specified.  */
       if (compile_options.sign_zero == 1)
-        sign = calculate_sign (dtp, sign_bit);
+	sign = calculate_sign (dtp, sign_bit);
       else
 	sign = calculate_sign (dtp, 0);
     }
@@ -987,9 +1022,9 @@ quadmath_snprintf (buffer, size, "%+-#.*Qf", (prec), (val))
    10.0**e even when the final result will not be rounded to 10.0**e.
    For these values the exponent returned by atoi has to be decremented
    by one. The values y in the ranges
-       (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
-        (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
-         (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
+	(1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1))
+	 (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2)
+	  (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1)
    are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)),
    100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0
    represents d zeroes, by the lines 279 to 297. */
@@ -1118,7 +1153,7 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
 	  d = precision;\
 	}\
       /* The switch between FMT_E and FMT_F is based on the absolute value.  \
-         Set r=0 for rounding toward zero and r = 1 otherwise.  \
+	 Set r=0 for rounding toward zero and r = 1 otherwise.  \
 	 If (exp_d - m) == 1 there is no rounding needed.  */\
       switch (dtp->u.p.current_unit->round_status)\
 	{\