[PATCH, fortran] PR93727 Implement new EX format specifier
Jerry D <[email protected]>
| Newsgroups | gmane.comp.gcc.patches,gmane.comp.gcc.fortran |
|---|---|
| Message-ID | <[email protected]> |
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.
0001-Fortran-PR93727-Implement-EX-format-specifier-for-WR.patch
(text/x-patch, 33.4 KB)
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