Attached patch fixes everything so far.
See my annotations below.
-- Jerry
On 2/1/26 3:00 PM, Jerry D wrote:
On 2/1/26 12:44 PM, Harald Anlauf wrote:
Hi Jerry,
thanks for your draft patch!
I don't mind implementing it step by step, but it does not
work here as I think it should (based on two other compilers).
Let's look at the testcases first:
- real(10) should be restricted to platforms where this is
available; it will be rejected on several others
I found one compiler that did not support real(10) even though the hardware has
it and it did support real(16). Some don't do either. I am certain we need to
set target in the test cases
- EXformat_1.f90
r4 = -huge(1.0_4/3.0_4)
this is identical to
r4 = -huge(1.0_4)
Fixed
Yes, I will tweak that.
and should print as:
-0XF.FFFFFP+124
Fixed (note system dependent on the first hex digit):
write(s1,"(EX0.0,'<')") r4
if (s1.ne."-0X1.FFFFFEP+127<") stop 1
write(s1,"(EX0.0,'<')") r8
if (s1.ne."-0X1.FFFFFFFFFFFFFP+1023<") stop 2
write(s1,"(EX0.0,'<')") r10
if (s1.ne."-0XF.FFFFFFFFFFFFFFFP+16380<") stop 3
and not
-0X1.P+127
hmm, I Added an = sign in a conditional looking at something else and forgot
to take it back out.
/* Handle the 'd' parameter - adjust mantissa precision if specified */
if (d > 0) <---------- I had >=, my bad.
{
This gives:
123456789012345678901234567890
-0X1.FFFFFEP+127<
-0X1.FFFFFFFFFFFFFP+1023<
-0XF.FFFFFFFFFFFFFFFP+16380<
Notice how this implementation normalizes differently then others.
etc.
Similarly for EXformat_2.f90, the first write should be
> -0X9.D14707B63DFBP+3<
Fixed and now:
write(str1, '(">",EX30.0,"<")') num
if (str1.ne."> -0X1.3A28E0F6C7BF6P+6<") stop 1
Also system dependent, compiler dependent.
and not
> -0X1.P+6<
Likwise, thanks for seeing these.
I would also recommend to extend the string length s1 so that
other brands do not complain about it being to short:
character(kind=1, len=16) :: s1
Easy to do.
Fixed to len=45
I also get a warning at compilation of io.cc:
../../gcc-trunk/gcc/fortran/io.cc: In function 'format_token format_lex()':
../../gcc-trunk/gcc/fortran/io.cc:449:11: warning: this statement may fall
through [-Wimplicit-fallthrough=]
449 | switch (c)
| ^~~~~~
../../gcc-trunk/gcc/fortran/io.cc:464:9: note: here
464 | case 'Z':
| ^~~~
Can you check the logic?
Found it and fixed, missed a ' break; '
Yes, I did not see it fly by, but will check.
I stopped the review here.
Feel free to continue.
Finally a few general comments: please try to stick to the
80 columns/line recommendation for commit messages as well
as for code.
I went through and fixed line lengths.
Agree, I can adjust.
Best,
Harald
--- snip ---
Thanks for the review. I will fix these and resubmit.
Jerry
commit 3f327b9d8077170f955cdebf288a84f6121da727
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..350fd3b4af5 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,37 @@ 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;
+ }
+ break;
+
+ case 'Z':
+ token = FMT_LZ;
+ break;
+
+ default:
+ token = FMT_UNKNOWN;
+ unget_char ();
+ break;
+ }
token = FMT_L;
break;
@@ -746,6 +779,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 +913,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..176b37bdd9c
--- /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=48) :: s1
+ real(4) :: r4
+ real(8) :: r8
+ real(10) :: r10
+ !real(16) :: r16
+ r4 = -huge(1.0_4)
+ r8 = -huge( 1.0_8)
+ r10= -huge(1.0_10)
+ !r16 = 1.0_16/3.0_16
+
+ write(s1,"(EX0.0,'<')") r4
+ if (s1.ne."-0X1.FFFFFEP+127<") stop 1
+ write(s1,"(EX0.0,'<')") r8
+ if (s1.ne."-0X1.FFFFFFFFFFFFFP+1023<") stop 2
+ write(s1,"(EX0.0,'<')") r10
+ if (s1.ne."-0XF.FFFFFFFFFFFFFFFP+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.4P-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..2cbd6b7d0f4
--- /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=45) :: str1
+
+ num = -3.14159682678_wp * 25._wp
+ write(str1, '(">",EX30.0,"<")') num
+ if (str1.ne."> -0X1.3A28E0F6C7BF6P+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..1fd0908859f 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_ex);
+
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..e641f1b7664 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,185 @@ 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, 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 */
+
+ /* 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 (out != NULL)
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *out4 = (gfc_char4_t *) out;
+ memset4 (out4, '*', w);
+ }
+ else
+ 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 +2118,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 +2226,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 +2524,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 +2620,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 +2783,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 +2850,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)\
{\
