The attached patch is the first step in implementing the EX format specifier.
As noted in the Change Log, I chose to hold off on the KIND=16 hex float output for a future patch. Likewise for the corresponding READ implementation. Unfortunately I ran into a number of places in the files where tabs were not used for indentation. I opted to fix those now as my editor does it on the fly.
The two new test cases pass on x86_64. Some implementations of the %A in snprintf may normalize the hex representation differently. I am hoping we can get some broader testing of this so I can set the { target *-*-* } for those that pass the tests.
I intend to take care of the READ and KIND=16 implementations in my next round. I Would like this to get into the wild if I may. Regression tested on x86_64-linux-gnu. Comments welcome. OK for mainline? Regards, Jerry 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.
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)\ {\
