https://gcc.gnu.org/g:73e6f2de0e606bf312377ac2dafec3bbf095241a
commit r17-2529-g73e6f2de0e606bf312377ac2dafec3bbf095241a Author: Jerry DeLisle <[email protected]> Date: Wed Jul 15 20:29:38 2026 -0700 fortran: Implement list directed read of hex float formats. PR libfortran/93727 libgfortran/ChangeLog: * io/list_read.c (parse_real): Parse the possible hexadecimal float formatted and then allow the convert_real function to validate the result. gcc/testsuite/ChangeLog: * gfortran.dg/EXformat_5.F90: New test. Diff: --- gcc/testsuite/gfortran.dg/EXformat_5.F90 | 131 +++++++++++++++++++++++++++++++ libgfortran/io/list_read.c | 85 ++++++++++++++++++++ 2 files changed, 216 insertions(+) diff --git a/gcc/testsuite/gfortran.dg/EXformat_5.F90 b/gcc/testsuite/gfortran.dg/EXformat_5.F90 new file mode 100644 index 000000000000..cfd699dd6412 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/EXformat_5.F90 @@ -0,0 +1,131 @@ +! { dg-do run } +! PR93727 Test hex float for list-directed READ. + +program main + implicit none + call test04 + call test08 + call test10 + call test16 + +contains + +subroutine test04 + real(4) :: r4, a, b + real(4) :: arr(3) + complex(4) :: z + character(len=64) :: s + + ! Round-trip + s = ' ' + write(s,'(EX0.0)') -huge(1.0_4) + read(s,*) r4 + if (r4 /= -huge(1.0_4)) stop 1 + + s = '0X1.8P+0' ! = 1.5 + read(s,*) r4 + if (r4 /= 1.5_4) stop 2 + + s = '-0X1.P+0' ! = -1.0 + read(s,*) r4 + if (r4 /= -1.0_4) stop 3 + + ! Lowercase + s = '0x1.8p-1' ! = 0.75 + read(s,*) r4 + if (r4 /= 0.75_4) stop 4 + + ! Hex digit 'E' is not an exponent. + s = '0X1.EP+3' ! (1 + 14/16) * 8 = 15.0 + read(s,*) r4 + if (r4 /= 15.0_4) stop 5 + + ! Comma-separated list of hex values. + s = '0X1P0, 0X1.8P+1' + read(s,*) a, b + if (a /= 1.0_4 .or. b /= 3.0_4) stop 6 + + ! Using a repeat count + s = '3*0X1P+1' + read(s,*) arr + if (any(arr /= 2.0_4)) stop 7 + + ! Complex constant with hex real and imaginary parts. + s = '(0X1P0, 0X1.8P+1)' + read(s,*) z + if (z /= (1.0_4, 3.0_4)) stop 8 +end subroutine test04 + + +subroutine test08 + real(8) :: r8, nx + character(len=64) :: s + namelist /nl8/ nx + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_8) + read(s,*) r8 + if (r8 /= -huge(1.0_8)) stop 10 + + ! Explicit hex: IEEE 754 representation of 1/3. + s = '0X1.5555555555555P-2' + read(s,*) r8 + if (r8 /= 1.0_8 / 3.0_8) stop 11 + + ! pi, double precision. + s = '0X1.921FB54442D18P+1' + read(s,*) r8 + if (abs(r8 - acos(-1.0_8)) > 2.0_8 * epsilon(r8)) stop 12 + + ! Hex value inside a NAMELIST. + nx = -999.0_8 + s = '&nl8 nx=0X1.8P+3 /' + read(s,nml=nl8) + if (nx /= 12.0_8) stop 13 + +end subroutine test08 + + +#ifdef __GFC_REAL_10__ +subroutine test10 + real(10) :: r10 + character(len=64) :: s + + s = ' ' + write(s,'(EX0.0)') -huge(1.0_10) + read(s,*) r10 + if (r10 /= -huge(1.0_10)) stop 14 + + s = '0X1.8P+0' + read(s,*) r10 + if (r10 /= 1.5_10) stop 15 + +end subroutine test10 +#else +subroutine test10 +end subroutine test10 +#endif + + +#ifdef __GFC_REAL_16__ +subroutine test16 + real(16) :: r16 + character(len=64) :: s + + s = ' ' + write(s,'(EX0.0)') -huge(1.0_16) + read(s,*) r16 + if (r16 /= -huge(1.0_16)) stop 16 + + s = '0X1.8P+0' + read(s,*) r16 + if (r16 /= 1.5_16) stop 17 + +end subroutine test16 +#else +subroutine test16 +end subroutine test16 +#endif + +end program main diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 2b577baa7d3c..f2179e2a1d89 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -1539,6 +1539,17 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) seen_dp = (c == '.') ? 1 : 0; + if (c == '0') + { + int c2 = next_char (dtp); + if (c2 == 'x' || c2 == 'X') + { + push_char (dtp, c2); + goto hex_real; + } + unget_char (dtp, c2); + } + for (;;) { if ((c = next_char (dtp)) == EOF) @@ -1644,6 +1655,30 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) } } + /* Hexadecimal format so collect the remaining characters. + The convert_real will validate it. */ + hex_real: + for (;;) + { + if ((c = next_char (dtp)) == EOF) + goto bad; + switch (c) + { + case '!': + if (!dtp->u.p.namelist_mode) + goto bad; + /* Fall through. */ + + CASE_SEPARATORS: + case ')': + goto done; + + default: + push_char (dtp, c); + break; + } + } + done: unget_char (dtp, c); push_char (dtp, '\0'); @@ -1878,6 +1913,17 @@ next: switch (c) { CASE_DIGITS: + if (c == '0') + { + int c2 = next_char (dtp); + if (c2 == 'x' || c2 == 'X') + { + push_char (dtp, c); + push_char (dtp, c2); + goto hex_real; + } + unget_char (dtp, c2); + } push_char (dtp, c); break; @@ -2018,6 +2064,17 @@ next: push_char (dtp, c); + if (c == '0') + { + int c2 = next_char (dtp); + if (c2 == 'x' || c2 == 'X') + { + push_char (dtp, c2); + goto hex_real; + } + unget_char (dtp, c2); + } + real_loop: for (;;) { @@ -2117,6 +2174,34 @@ next: } } + /* Hexadecimal-significand form: [sign] 0X hex-significand P + decimal-exp (F2023 13.7.2.3.2 para 7), also accepted on list-directed + input per the same rules as Fw.d editing. The '0X'/'0x' prefix has + already been pushed; collect the remaining characters (hex digits, + radix point, P/p exponent letter, exponent sign) verbatim up to the + next separator and let convert_real/strtod validate and parse the + whole thing, just as read_ex does for formatted EX input. */ + hex_real: + for (;;) + { + c = next_char (dtp); + switch (c) + { + case '!': + if (!dtp->u.p.namelist_mode) + goto bad_real; + /* Fall through. */ + + CASE_SEPARATORS: + case EOF: + goto done; + + default: + push_char (dtp, c); + break; + } + } + done: unget_char (dtp, c); eat_separator (dtp);
