https://gcc.gnu.org/g:5d0a9050f3a1c1f9f8e89188dec3d6f39c64a06a
commit r17-702-g5d0a9050f3a1c1f9f8e89188dec3d6f39c64a06a Author: Jerry DeLisle <[email protected]> Date: Sun May 10 18:13:48 2026 -0700 Fortran: [PR93727] Implement EX format specifier for WRITE These changes implement a portion of the Fortran 2018 EX format specifier for WRITE output. 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. Remaining to be completed is proper rounding of truncated hex float strings and implementing the READ functions. These will be a followup patches. 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. Co-Authored-By: Harald Anlauf <[email protected]> Diff: --- gcc/fortran/io.cc | 45 ++++- gcc/testsuite/gfortran.dg/EXformat_1.F90 | 58 ++++++ 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, 663 insertions(+), 48 deletions(-) diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc index 0a81d4a168ad..16d548716110 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 000000000000..a4bde816eeae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/EXformat_1.F90 @@ -0,0 +1,58 @@ +! { dg-do run } +! pr93727 EX Format Specifiers, testing various kinds, default field widths +program main + implicit none + character(kind=1, len=48) :: s1 + + call test04 + call test08 + call test10 + call test16 + +contains + +subroutine test04 + real(4) :: r4 + r4 = -huge(1.0_4) + write(s1,"(EX0.0,'<')") r4 + if (s1.ne."-0XF.FFFFFP+124<") stop 1 + write(s1,"(EX0.0,'<')") 1.0_4/r4 + if (s1.ne."-0X8.P-131<") stop 2 +end subroutine test04 + +subroutine test08 + real(8) :: r8 + r8 = -huge( 1.0_8) + write(s1,"(EX0.0,'<')") r8 + if (s1.ne."-0XF.FFFFFFFFFFFF8P+1020<") stop 3 + write(s1,"(EX0.0,'<')") 1.0_8/r8 + if (s1.ne."-0X8.P-1027<") stop 4 +end subroutine test08 + +#ifdef __GFC_REAL_10__ +subroutine test10 + real(10) :: r10 + r10 = -huge(1.0_10) + write(s1,"(EX0.0,'<')") r10 + if (s1.ne."-0XF.FFFFFFFFFFFFFFFP+16380<") stop 5 + write(s1,"(EX0.0,'<')") 1.0_10/r10 + if (s1.ne."-0X8.P-16387<") stop 6 +end subroutine test10 +#else +subroutine test10 +end subroutine test10 +#endif + +#ifdef __GFC_REAL_16__ +subroutine test16 + real(16) :: r16 + r16 = 1.0_16/3.0_16 + write(s1,"(EX0.0,'<')") r16 + if (s1.ne."0XA.AAAAAAAAAAAAAAAAAAAAAAAAAAA8P-5<") stop 7 +end subroutine test16 +#else +subroutine test16 +end subroutine test16 +#endif + +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 000000000000..69f7482a6a53 --- /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 899a0b50f95c..cff94a63f792 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 7928c196f63f..1fd0908859f4 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 c81993e4635e..99e90f3c8034 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 a5e89c649510..44f4b614c4fe 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 8732df49b281..608106af7c7b 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)\ {\
