Hi all,
This took me a lot longer than I wanted, but finally got it done.
See the attached patch. Since my last submittal here I started over on using the
example demo Harald gave in Comment 18 of the PR using available higher level C
functions, fabs, signbit, scalbn, isnan frexp, etc to extract the needed
components. Then, using the %H specifier to build the hexadecimal float string
in get_float_hex_string(). I added checks for zero, inf, nan, and the sign.
Once I had this working for kind=8, I repeated the pattern for kind=8, 10, and
16. I used defines around the kind=10 and 16 to avoid where not supported.
I also created defines for the C functions needed following the examples later
in the file. I dont have some of those platforms readily available here so a web
searched for those various function, ie not tested yet. I will call it an EWAG.
Engineering Wild Assumption and Guess.
I apologize for the whitespace cleanups. I had them in my worktree from earlier
attempts.
I updated the two test cases added. I probably need to specify targets on those.
We can add additional testcases as deemed appropriate.
Regression tested here on X86_64. Testing by others encouraged.
OK for mainline. I do not plan any backport and less others think its worth it.
Best regards,
Jerry
PS I will be on travel the next 7 day however I can monitor email.
From 28afb48d5292268f542f23fdc1096797157e74d9 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sun, 10 May 2026 18:13:48 -0700
Subject: [PATCH] Fortran: [PR93727] Implement EX format specifier for WRITE
These changes implement the Fortran 2018 EX format specifier
for WRITE output. READ will be a later change. This implements
hexadecimal floating point formats for KIND=4,8,10, and 16 real
numbers if supported by the configured machine.
Format tokens are added as place holders for future leading
zero specifiers.
PR fortran/93727
gcc/fortran/ChangeLog:
* io.cc (enum format_token): Add FMT_EX, FMT_LPS, FMT_LPZ, FMT_LZ
enums to identify specific tokens.
(format_lex): Add parsing and checking of the EXw.d and EXw.dEe edit
specifiers.
libgfortran/ChangeLog:
* io/format.c (format_lex): Add new FMT_EX token handing.
(parse_format_list): Likewise.
(next_format): Likewise
* io/io.h (write_ex): Add prototype for new function.
(internal_proto): Likewise.
* io/transfer.c (formatted_transfer_scalar_write): Use FMT_EX token.
* io/write.c (write_default_char4): White space fix.
(write_a): White space fix.
(write_boz): White space fix.
(write_decimal): White space fix.
(otoa_big): White space fix.
(write_character): White space fix.
(write_float_0): White space fix.
(write_ex): New function which uses the new helper function
get_float_hex_string() to build the hexadecimal float format for
output.
(write_real): White space fix.
(write_complex): White space fix.
(nml_write_obj): White space fix.
(namelist_write): White space fix.
* io/write_float.def: Add defines to handle the various forms of
KIND=16 floats. These handle the selection of the appropriate versions
of the frexp, fabs, and scalbn used to extract the components of the
floating point values.
(GFC_REAL_16_FREXP): New define.
(GFC_REAL_16_FABS): New define.
(GFC_REAL_16_SCALBN): New define.
(get_float_hex_string): New function which exatracts the bits and builds
the basic hexadecimal format strings into a buffer. The buffer is provided
by the caller write_ex.
(build_float_string): White space fix.
(quadmath_snprintf): White space fix.
(determine_en_precision): White space fix.
gcc/testsuite/ChangeLog:
* gfortran.dg/EXformat_1.f90: New test.
* gfortran.dg/EXformat_2.f90: New test.
---
gcc/fortran/io.cc | 45 +++-
gcc/testsuite/gfortran.dg/EXformat_1.f90 | 30 +++
gcc/testsuite/gfortran.dg/EXformat_2.f90 | 24 ++
libgfortran/io/format.c | 11 +-
libgfortran/io/io.h | 6 +-
libgfortran/io/transfer.c | 11 +-
libgfortran/io/write.c | 245 ++++++++++++++++--
libgfortran/io/write_float.def | 311 ++++++++++++++++++++++-
8 files changed, 635 insertions(+), 48 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/EXformat_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/EXformat_2.f90
diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc
index 0a81d4a168a..16d54871611 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..1d95ca7b385
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/EXformat_1.f90
@@ -0,0 +1,30 @@
+! { 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."-0XF.FFFFFP+124<") stop 1
+ write(s1,"(EX0.0,'<')") r8
+ if (s1.ne."-0XF.FFFFFFFFFFFF8P+1020<") 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."-0X8.P-131<") stop 4
+ write(s1,"(EX0.0,'<')") 1.0_8/r8
+ if (s1.ne."-0X8.P-1027<") stop 5
+ write(s1,"(EX0.0,'<')") 1.0_10/r10
+ if (s1.ne."-0X8.P-16387<") stop 6
+ write(s1,"(EX0.0,'<')") r16
+ if (s1.ne."0XA.AAAAAAAAAAAAAAAAAAAAAAAAAAA8P-5<") stop 7
+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..69f7482a6a5
--- /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."> -0X9.D14707B63DFBP+3<") stop 1
+ write(str1, '(">",EX30.1,"<")') num
+ if (str1.ne."> -0X9.DP+3<") stop 2
+ write(str1, '(">",EX30.2,"<")') num
+ if (str1.ne."> -0X9.D1P+3<") stop 3
+ write(str1, '(">",EX30.3,"<")') num
+ if (str1.ne."> -0X9.D14P+3<") stop 4
+ write(str1, '(">",EX30.4,"<")') num
+ if (str1.ne."> -0X9.D147P+3<") stop 5
+ write(str1, '(">",EX30.15e8,"<")') num
+ if (str1.ne.">-0X9.D14707B63DFB000P+00000003<") 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 899a0b50f95..cff94a63f79 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 c81993e4635..99e90f3c803 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..44f4b614c4f 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,196 @@ 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. 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;
+
+ /* 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 */
+ 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 - trim trailing zeros before 'P'. */
+ if (d == 0)
+ {
+ decimal = strchr (buf, '.');
+ if (decimal != NULL && decimal < p_pos)
+ {
+ char *trim = p_pos - 1;
+ while (trim > decimal && *trim == '0')
+ trim--;
+ /* Shift 'P...' part left to just after last non-zero digit. */
+ if (trim + 1 < p_pos)
+ {
+ memmove (trim + 1, p_pos, strlen (p_pos) + 1);
+ p_pos = trim + 1;
+ }
+ }
+ }
+
+ /* 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;
+ 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 +2129,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 +2237,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 +2535,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 +2631,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 +2794,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 +2861,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..608106af7c7 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -26,6 +26,295 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "config.h"
+/* Math function dispatch macros for kind=16. The type and its math functions
+ vary by platform: _Float128 (IEC 60559), __float128 (libquadmath, including
+ POWER_IEEE128), or 128-bit long double. */
+#ifdef HAVE_GFC_REAL_16
+# if defined(GFC_REAL_16_IS_FLOAT128)
+# if defined(GFC_REAL_16_USE_IEC_60559)
+# define GFC_REAL_16_FREXP(x, e) frexpf128 (x, e)
+# define GFC_REAL_16_FABS(x) fabsf128 (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnf128 (x, n)
+# else /* libquadmath __float128, including POWER_IEEE128 */
+# define GFC_REAL_16_FREXP(x, e) frexpq (x, e)
+# define GFC_REAL_16_FABS(x) fabsq (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnq (x, n)
+# endif
+# else /* 128-bit long double */
+# define GFC_REAL_16_FREXP(x, e) frexpl (x, e)
+# define GFC_REAL_16_FABS(x) fabsl (x)
+# define GFC_REAL_16_SCALBN(x, n) scalbnl (x, n)
+# endif
+#endif /* HAVE_GFC_REAL_16 */
+
+/* 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 derived from the
+ IEEE-754 bit representations. Non-IEEE-754 representations are not
+ supported. Sets '*res_len' to the length of the string,
+ excluding NUL terminator. The buffer must be at least 64 bytes to
+ contain the resulting string for all kinds. */
+static int
+get_float_hex_string (const void *source, int kind, char *buffer,
+ int *res_len)
+{
+ int result = -1;
+ bool is_negative;
+ *res_len = 0;
+
+ switch (kind)
+ {
+ case 4:
+ {
+ GFC_REAL_4 val;
+ GFC_REAL_4 mant;
+ int expon;
+ int int_part;
+ unsigned int frac_part;
+
+ val = *(const GFC_REAL_4 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0f)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexpf (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0f)
+ {
+ mant = fabsf (mant);
+ mant = scalbnf (mant, 4);
+ expon -= 4;
+ if (mant < 8.f)
+ {
+ mant = scalbnf (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 24 is the nearest integer divisible by 4 that is >= 23 (mantissa bits
+ for kind=4). (24-4)/4 = 5 hex digits for the fractional part. */
+ frac_part = (unsigned int) scalbnf (mant - (GFC_REAL_4) int_part, 24 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 16, "-0X%X.%5.5XP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 16, "0X%X.%5.5XP%+d", int_part, frac_part, expon);
+ }
+ break;
+ case 8:
+ {
+ double val;
+ double mant;
+ int expon;
+ int int_part;
+ unsigned long frac_part;
+
+ val = *(const GFC_REAL_8 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexp (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0)
+ {
+ mant = fabs (mant);
+ mant = scalbn (mant, 4);
+ expon -= 4;
+ if (mant < 8.)
+ {
+ mant = scalbn (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 56 is the nearest integer divisible by 4 that is >= 53 (mantissa bits
+ for kind=8). (56-4)/4 = 13 hex digits for the fractional part. */
+ frac_part = (unsigned long) scalbn (mant - (double) int_part, 56 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 25, "-0X%X.%13.13lXP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 25, "0X%X.%13.13lXP%+d", int_part, frac_part, expon);
+ }
+ break;
+#ifdef HAVE_GFC_REAL_10
+ case 10:
+ {
+ GFC_REAL_10 val;
+ GFC_REAL_10 mant;
+ int expon;
+ int int_part;
+ unsigned long long frac_part;
+
+ val = *(const GFC_REAL_10 *) source;
+ is_negative = signbit (val);
+ if (val == 0.0L)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = frexpl (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != 0.0L)
+ {
+ mant = fabsl (mant);
+ mant = scalbnl (mant, 4);
+ expon -= 4;
+ if (mant < 8.L)
+ {
+ mant = scalbnl (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 64 is the nearest integer divisible by 4 that is >= 64 (mantissa bits
+ for kind=10). (64-4)/4 = 15 hex digits for the fractional part. */
+ frac_part = (unsigned long long) scalbnl (mant - (GFC_REAL_10) int_part, 64 - 4);
+ if (is_negative)
+ result = snprintf (buffer, 28, "-0X%X.%15.15llXP%+d", int_part, frac_part, expon);
+ else
+ result = snprintf (buffer, 28, "0X%X.%15.15llXP%+d", int_part, frac_part, expon);
+ }
+ break;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ case 16:
+ {
+ GFC_REAL_16 val;
+ GFC_REAL_16 mant;
+ int expon;
+ int int_part;
+ unsigned long long frac_hi, frac_lo;
+ GFC_REAL_16 frac_val, frac_lo_val;
+
+ val = *(const GFC_REAL_16 *) source;
+ is_negative = signbit (val);
+ if (val == (GFC_REAL_16) 0.0)
+ {
+ if (is_negative)
+ result = snprintf (buffer, 9, "-0X0.P0");
+ else
+ result = snprintf (buffer, 8, "0X0.P0");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isinf (val))
+ {
+ if (is_negative)
+ result = snprintf (buffer, 5, "-Inf");
+ else
+ result = snprintf (buffer, 4, "Inf");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ if (isnan (val))
+ {
+ result = snprintf (buffer, 4, "NaN");
+ *res_len = result;
+ return result < 0 ? -1 : 0;
+ }
+ mant = GFC_REAL_16_FREXP (val, &expon);
+ /* Scale mantissa so the leading hex digit is in the range [8, 15]. */
+ if (mant != (GFC_REAL_16) 0.0)
+ {
+ mant = GFC_REAL_16_FABS (mant);
+ mant = GFC_REAL_16_SCALBN (mant, 4);
+ expon -= 4;
+ if (mant < (GFC_REAL_16) 8.)
+ {
+ mant = GFC_REAL_16_SCALBN (mant, 1);
+ expon -= 1;
+ }
+ }
+ int_part = (int) mant;
+ /* 116 is the nearest integer divisible by 4 that is >= 113 (mantissa
+ bits for kind=16). (116-4)/4 = 28 hex digits for the fractional
+ part, split into two 56-bit halves (14 hex digits each) to fit in
+ unsigned long long. */
+ frac_val = mant - (GFC_REAL_16) int_part;
+ frac_hi = (unsigned long long) GFC_REAL_16_SCALBN (frac_val, 56);
+ frac_lo_val = frac_val - GFC_REAL_16_SCALBN ((GFC_REAL_16) frac_hi, -56);
+ frac_lo = (unsigned long long) GFC_REAL_16_SCALBN (frac_lo_val, 112);
+ if (is_negative)
+ result = snprintf (buffer, 42, "-0X%X.%14.14llX%14.14llXP%+d",
+ int_part, frac_hi, frac_lo, expon);
+ else
+ result = snprintf (buffer, 42, "0X%X.%14.14llX%14.14llXP%+d",
+ int_part, frac_hi, frac_lo, expon);
+ }
+ break;
+#endif /* HAVE_GFC_REAL_16 */
+ default:
+ return -1;
+ }
+ if (result < 0)
+ return -1;
+
+ *res_len = result;
+ return 0;
+}
+
typedef enum
{ S_NONE, S_MINUS, S_PLUS }
sign_t;
@@ -186,7 +475,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 +599,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 +617,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 +733,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 +851,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 +1276,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 +1407,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)\
{\
--
2.54.0
