https://gcc.gnu.org/g:77d5b22efb2b0c291b572f087371d7dc462d5499
commit r17-1487-g77d5b22efb2b0c291b572f087371d7dc462d5499 Author: Jerry DeLisle <[email protected]> Date: Mon May 25 21:13:19 2026 -0700 Fortran: [PR93727] Add EX format READ (read_ex) Implement read_ex in libgfortran to handle EX edit-descriptor input per Fortran 2023 13.7.2.3.6. The input field may contain: * a hexadecimal-significand form (0X<sig>P<exp>) passed directly to the C strtod/strtold family for exact bit-for-bit conversion; * any form acceptable for Fw.d input (decimal fallback), including INF and NAN representations. For decimal input without a decimal point the d field of the EX.w.d descriptor adjusts the exponent exactly as for Fw.d. BN/BZ blank handling and the kP scale factor are also supported via the shared decimal path. Assisted by: Claude Sonnet 4.6 PR fortran/93727 libgfortran/ChangeLog: * io/read.c (read_ex): New function implementing EX format read. * io/io.h (read_ex): Declare. * io/transfer.c (formatted_transfer_scalar_read): Add FMT_EX case dispatching to read_ex. gcc/testsuite/ChangeLog: * gfortran.dg/EXformat_4.F90: New test covering EX format read for kind=4 and 8 (always) and kind=10, 16 (when available): hex-significand literals, lowercase prefix, negative binary exponent, decimal fallback, d-field adjustment, INF/NAN, zero field, and round-trips through write_ex. Diff: --- gcc/testsuite/gfortran.dg/EXformat_4.F90 | 172 +++++++++++++++ libgfortran/io/io.h | 3 + libgfortran/io/read.c | 358 +++++++++++++++++++++++++++++++ libgfortran/io/transfer.c | 8 + 4 files changed, 541 insertions(+) diff --git a/gcc/testsuite/gfortran.dg/EXformat_4.F90 b/gcc/testsuite/gfortran.dg/EXformat_4.F90 new file mode 100644 index 000000000000..c90857ac3e74 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/EXformat_4.F90 @@ -0,0 +1,172 @@ +! { dg-do run } +! PR93727 Test EX format READ (read_ex). +! Covers: hex-significand input (0X...P...), decimal fallback, round-trips, +! INF/NAN, and all supported real kinds. +program main + implicit none + call test04 + call test08 + call test10 + call test16 + +contains + +subroutine test04 + real(kind=4) :: r4 + character(kind=1,len=40) :: s + + ! Round-trip: write then read back. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_4) + read(s,'(EX40.0)') r4 + if (r4 /= -huge(1.0_4)) stop 1 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_4) + read(s,'(EX40.0)') r4 + if (r4 /= tiny(1.0_4)) stop 2 + + ! Explicit hex literal input. + s = '0X1.8P+0' ! = 1.5 exactly + read(s,'(EX40.0)') r4 + if (r4 /= 1.5_4) stop 3 + + s = '-0X1.P+0' ! = -1.0 + read(s,'(EX40.0)') r4 + if (r4 /= -1.0_4) stop 4 + + ! Decimal fallback: no 0X prefix, ordinary E-style input. + s = '1.5E0' + read(s,'(EX40.0)') r4 + if (r4 /= 1.5_4) stop 5 + + s = ' 1.5E2 ' + read(s,'(EX40.0)') r4 + if (r4 /= 150.0_4) stop 6 + + ! Zero field (blank record). + s = ' ' + read(s,'(EX4.0)') r4 + if (r4 /= 0.0_4) stop 7 + +end subroutine test04 + + +subroutine test08 + real(kind=8) :: r8 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_8) + read(s,'(EX40.0)') r8 + if (r8 /= -huge(1.0_8)) stop 8 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_8) + read(s,'(EX40.0)') r8 + if (r8 /= tiny(1.0_8)) stop 9 + + ! Explicit hex: IEEE 754 representation of 1/3. + s = '0X1.5555555555555P-2' + read(s,'(EX40.0)') r8 + if (r8 /= 1.0_8 / 3.0_8) stop 10 + + ! Negative hex. + s = '-0X1.8P+0' ! = -1.5 + read(s,'(EX40.0)') r8 + if (r8 /= -1.5_8) stop 11 + + ! Decimal fallback. + s = '3.14159265358979E0' + read(s,'(EX40.0)') r8 + if (abs(r8 - 3.14159265358979_8) > 2.0_8 * epsilon(r8)) stop 12 + + ! Round-trip on an interesting value. + s = ' ' + write(s,'(EX0.0)') -3.14159265358979_8 * 25.0_8 + read(s,'(EX40.0)') r8 + if (r8 /= -3.14159265358979_8 * 25.0_8) stop 13 + + ! Lowercase hex prefix and negative binary exponent. + s = '0x1.8p-1' ! = 0.75 + read(s,'(EX40.0)') r8 + if (r8 /= 0.75_8) stop 14 + + ! d-field: no decimal point in decimal input; d=2 places from right. + s = '12345 ' + read(s,'(EX10.2)') r8 + if (r8 /= 123.45_8) stop 15 + + ! INF and NaN input via decimal fallback path. + s = 'Inf' + read(s,'(EX40.0)') r8 + if (r8 <= huge(r8)) stop 16 + + s = '-Infinity' + read(s,'(EX40.0)') r8 + if (r8 >= -huge(r8)) stop 17 + + s = 'NaN' + read(s,'(EX40.0)') r8 + if (r8 == r8) stop 18 + +end subroutine test08 + + +#ifdef __GFC_REAL_10__ +subroutine test10 + real(kind=10) :: r10 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_10) + read(s,'(EX40.0)') r10 + if (r10 /= -huge(1.0_10)) stop 19 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_10) + read(s,'(EX40.0)') r10 + if (r10 /= tiny(1.0_10)) stop 20 + + ! Explicit hex: 1.5 = 0X1.8P+0 + s = '0X1.8P+0' + read(s,'(EX40.0)') r10 + if (r10 /= 1.5_10) stop 21 + +end subroutine test10 +#else +subroutine test10 +end subroutine test10 +#endif + + +#ifdef __GFC_REAL_16__ +subroutine test16 + real(kind=16) :: r16 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_16) + read(s,'(EX40.0)') r16 + if (r16 /= -huge(1.0_16)) stop 22 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_16) + read(s,'(EX40.0)') r16 + if (r16 /= tiny(1.0_16)) stop 23 + + ! Explicit hex: 1.5 = 0X1.8P+0 + s = '0X1.8P+0' + read(s,'(EX40.0)') r16 + if (r16 /= 1.5_16) stop 24 + +end subroutine test16 +#else +subroutine test16 +end subroutine test16 +#endif + +end program main diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 1fd0908859f4..d131d9544c4f 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -887,6 +887,9 @@ internal_proto(read_a); extern void read_f (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_f); +extern void read_ex (st_parameter_dt *, const fnode *, char *, int); +internal_proto(read_ex); + extern void read_l (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_l); diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index aeec725684bf..047fff11643f 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -1525,6 +1525,364 @@ bad_float: } +/* read_ex()-- Read a floating-point number with EX editing. + Per Fortran 2023 13.7.2.3.6 para 3, the input form is the same as for + Fw.d editing (13.7.2.3.2). That includes the hexadecimal-significand + form (13.7.2.3.2 para 7): [sign] 0X [hex-significand] P [decimal-exp]. + Decimal mantissas and IEEE exceptional forms (INF, NAN) are also + accepted. Embedded blanks are not permitted within a hex float; C + strtod handles the 0x...p... form natively. */ + +void +read_ex (st_parameter_dt *dtp, const fnode *f, char *dest, int length) +{ +#define READEX_TMP 64 + char tmp[READEX_TMP]; + size_t buf_size = 0; + size_t w; + int seen_dp, exponent; + int exponent_sign; + const char *p; + char *buffer; + char *out; + int seen_int_digit; + int seen_dec_digit; + + seen_dp = 0; + seen_int_digit = 0; + seen_dec_digit = 0; + exponent_sign = 1; + exponent = 0; + w = f->u.real.w; + buffer = tmp; + + p = read_block_form (dtp, &w); + if (p == NULL) + return; + p = eat_leading_spaces (&w, (char *) p); + if (w == 0) + goto zero; + + buf_size = w + 11; + if (buf_size > READEX_TMP) + buffer = xmalloc (buf_size); + + out = buffer; + + /* Optional sign. */ + if (*p == '-' || *p == '+') + { + if (*p == '-') + *(out++) = '-'; + ++p; + --w; + } + + p = eat_leading_spaces (&w, (char *) p); + if (w == 0) + { + if (buf_size > READEX_TMP) + free (buffer); + goto zero; + } + + /* IEEE exceptional specification: INF or NAN. */ + if (unlikely (w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))) + { + int seen_paren = 0; + char *save = out; + + while (w > 0) + { + *out = safe_tolower (*p); + switch (*p) + { + case ' ': + if (dtp->u.p.blank_status == BLANK_ZERO) + { + *out = '0'; + break; + } + *out = '\0'; + if (seen_paren == 1) + goto bad_float; + break; + case '(': + seen_paren++; + *out = '\0'; + break; + case ')': + if (seen_paren++ != 1) + goto bad_float; + break; + default: + if (!safe_isalnum (*out)) + goto bad_float; + } + --w; + ++p; + ++out; + } + + *out = '\0'; + + if (seen_paren != 0 && seen_paren != 2) + goto bad_float; + + if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0)) + { + if (seen_paren) + goto bad_float; + } + else if (strcmp (save, "nan") != 0) + goto bad_float; + + convert_infnan (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + } + + /* Hexadecimal-significand number: 0X or 0x prefix. + Embedded blanks are forbidden; we stop at the first blank and let + convert_real report an error if the string is malformed. */ + if (w >= 2 && *p == '0' && (p[1] == 'x' || p[1] == 'X')) + { + while (w > 0 && *p != ' ') + { + *(out++) = *p++; + --w; + } + *(out++) = '\0'; + + convert_real (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + } + + /* Decimal floating-point fallback: same rules as Fw.d editing. */ + while (w > 0) + { + switch (*p) + { + case ',': + if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA) + goto bad_float; + if (seen_dp) + goto bad_float; + if (!seen_int_digit) + *(out++) = '0'; + *(out++) = '.'; + seen_dp = 1; + break; + + case '.': + if (dtp->u.p.current_unit->decimal_status != DECIMAL_POINT) + goto bad_float; + if (seen_dp) + goto bad_float; + if (!seen_int_digit) + *(out++) = '0'; + *(out++) = '.'; + seen_dp = 1; + break; + + case ' ': + if (dtp->u.p.blank_status == BLANK_ZERO) + { + *(out++) = '0'; + goto found_digit; + } + else if (dtp->u.p.blank_status == BLANK_NULL) + break; + else + goto done; + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + *(out++) = *p; +found_digit: + if (!seen_dp) + seen_int_digit = 1; + else + seen_dec_digit = 1; + break; + + case '-': + case '+': + goto exponent; + + case 'e': + case 'E': + case 'd': + case 'D': + case 'q': + case 'Q': + ++p; + --w; + goto exponent; + + default: + goto bad_float; + } + + ++p; + --w; + } + + /* No exponent seen; apply the scale factor. */ + exponent = -dtp->u.p.scale_factor; + goto done; + +exponent: + p = eat_leading_spaces (&w, (char *) p); + if (*p == '-' || *p == '+') + { + if (*p == '-') + exponent_sign = -1; + ++p; + --w; + } + + if (w == 0) + { + if (dtp->common.flags & IOPARM_DT_DEC_EXT) + goto done; + else + goto bad_float; + } + + if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) + { + while (w > 0 && safe_isdigit (*p)) + { + exponent *= 10; + exponent += *p - '0'; + ++p; + --w; + } + while (w > 0) + { + if (*p != ' ') + goto bad_float; + ++p; + --w; + } + } + else + { + while (w > 0) + { + if (*p == ' ') + { + if (dtp->u.p.blank_status == BLANK_ZERO) + exponent *= 10; + else + assert (dtp->u.p.blank_status == BLANK_NULL); + } + else if (!safe_isdigit (*p)) + goto bad_float; + else + { + exponent *= 10; + exponent += *p - '0'; + } + ++p; + --w; + } + } + + exponent *= exponent_sign; + +done: + if (!seen_dp) + exponent -= f->u.real.d; + + if (seen_dp && !seen_dec_digit) + *(out++) = '0'; + else if (!seen_int_digit && !seen_dec_digit) + { + notify_std (&dtp->common, GFC_STD_LEGACY, + "REAL input of style 'E+NN'"); + *(out++) = '0'; + } + + if (exponent != 0) + { + int dig; + + *(out++) = 'e'; + if (exponent < 0) + { + *(out++) = '-'; + exponent = -exponent; + } + + if (exponent >= 10000) + goto bad_float; + + for (dig = 3; dig >= 0; --dig) + { + out[dig] = (char) ('0' + exponent % 10); + exponent /= 10; + } + out += 4; + } + *(out++) = '\0'; + + convert_real (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + +zero: + switch (length) + { + case 4: + *((GFC_REAL_4 *) dest) = 0.0; + break; + case 8: + *((GFC_REAL_8 *) dest) = 0.0; + break; +#ifdef HAVE_GFC_REAL_10 + case 10: + *((GFC_REAL_10 *) dest) = 0.0; + break; +#endif +#ifdef HAVE_GFC_REAL_16 + case 16: + *((GFC_REAL_16 *) dest) = 0.0; + break; +#endif +#ifdef HAVE_GFC_REAL_17 + case 17: + *((GFC_REAL_17 *) dest) = 0.0; + break; +#endif + default: + internal_error (&dtp->common, "Unsupported real kind during IO"); + } + return; + +bad_float: + if (buf_size > READEX_TMP) + free (buffer); + generate_error (&dtp->common, LIBERROR_READ_VALUE, + "Bad value during floating point read"); + next_record (dtp, 1); + return; +} + + /* read_x()-- Deal with the X/TR descriptor. We just read some data and never look at it. */ diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 6c583f76767c..d88cd810529f 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1840,6 +1840,14 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind read_f (dtp, f, p, kind); break; + case FMT_EX: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_ex (dtp, f, p, kind); + break; + case FMT_F: if (n == 0) goto need_read_data;
