https://gcc.gnu.org/g:3cf9262ae2c9cbefd40f2f9da0258b79c7f749af
commit r16-9253-g3cf9262ae2c9cbefd40f2f9da0258b79c7f749af Author: Jerry DeLisle <[email protected]> Date: Wed Jul 8 10:22:04 2026 -0700 fortran: [PR126116] Internal file I/O corrupts NEWUNIT state Before this fix, Performing an internal file I/O (such as WRITE to a character variable) incorrectly corrupts the internal unit management table in libgfortran. This patch adds a bool to the gfc_unit structure to allow tracking whether a gfc_unit was created for purposes of internal I/O to avoid the breakage. PR libfortran/126116 libgfortran/ChangeLog: * io/io.h (struct gfc_unit): Add bool for tracking. Fix some white space problems. * io/unit.c (close_unit_1): Add a declaration for this function so it can be called before it has been defined. Use the new bool. (is_internal_reserved): New helper function. Returns true only if the unit is not null and the internal unit kind is zero meaning its not a character string. (find_unit): Use the new helper function (find_or_create_unit): Use the new helper. (get_unit): Set the new bool. (close_unit): Update the close_unit_1 argument list. (close_units): Likewise. gcc/testsuite/ChangeLog: * gfortran.dg/pr126116.f90: New test. (cherry picked from commit 11be877aea73b0b26638078908a42dd0f97d81d7) Diff: --- gcc/testsuite/gfortran.dg/pr126116.f90 | 19 ++++++++++++++++ libgfortran/io/io.h | 13 ++++++----- libgfortran/io/unit.c | 41 +++++++++++++++++++++++++++++----- 3 files changed, 62 insertions(+), 11 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/pr126116.f90 b/gcc/testsuite/gfortran.dg/pr126116.f90 new file mode 100644 index 000000000000..420584e07dfd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr126116.f90 @@ -0,0 +1,19 @@ +! { dg-do run } + +program check + implicit none + integer :: u + character(50) :: chr + + ! 1. Correctly generate a negative unit via NEWUNIT + open(file="test.txt", newunit=u) ! u gets -10 + close(u) ! u (-10) is now closed and free + + ! 2. Internal I/O corrupts the state of unit -10 + write(chr, *) "test" + + ! 3. Redundant CLOSE on the valid unit 'u'. + ! This should be a safe no-op according to the standard, + ! but it triggers the runtime error/segfault! + close(u) +end program diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 7928c196f63f..f4ec625570d6 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -534,7 +534,7 @@ typedef struct st_parameter_dt character string is being read so don't use commas to shorten a formatted field width. */ unsigned sf_read_comma : 1; - /* A namelist specific flag used to enable reading input from + /* A namelist specific flag used to enable reading input from line_buffer for logical reads. */ unsigned line_buffer_enabled : 1; /* An internal unit specific flag used to identify that the associated @@ -648,7 +648,7 @@ typedef struct gfc_unit { int unit_number; stream *s; - + /* Treap links. */ struct gfc_unit *left, *right; int priority; @@ -705,10 +705,10 @@ typedef struct gfc_unit /* The format hash table. */ struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE]; - + /* Formatting buffer. */ struct fbuf *fbuf; - + /* Function pointer, points to list_read worker functions. */ int (*next_char_fn_ptr) (st_parameter_dt *); void (*push_char_fn_ptr) (st_parameter_dt *, int); @@ -719,6 +719,9 @@ typedef struct gfc_unit gfc_array_char *string_unit_desc; int internal_unit_kind; + /* Track when a gfc_unit is reserved for an internal unit. */ + bool internal_reserved; + /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ int child_dtio; @@ -1013,7 +1016,7 @@ predec_waiting_locked (gfc_unit *u) if (predec_waiting_locked (u) == 0) // destroy u - + could be further optimized by making this be an __ATOMIC_RELEASE, and then inserting a diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index fac24db014dc..5973cef108ce 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -478,17 +478,45 @@ found: } +static int close_unit_1 (gfc_unit *, int, bool); + + +/* Helper to check if an internal unit is reserved. */ + +static inline bool +is_internal_reserved (gfc_unit *u) +{ + return u->internal_reserved && u->internal_unit_kind == 0; +} + + gfc_unit * find_unit (int n) { - return get_gfc_unit (n, 0); + gfc_unit *u = get_gfc_unit (n, 0); + + if (u != NULL && is_internal_reserved (u)) + { + unlock_unit (u); + return NULL; + } + + return u; } gfc_unit * find_or_create_unit (int n) { - return get_gfc_unit (n, 1); + gfc_unit *u = get_gfc_unit (n, 1); + + if (u != NULL && is_internal_reserved (u)) + { + close_unit_1 (u, 0, false); + u = get_gfc_unit (n, 1); + } + + return u; } @@ -624,6 +652,7 @@ get_unit (st_parameter_dt *dtp, int do_create) dtp->u.p.unit_is_internal = 1; dtp->common.unit = newunit_alloc (); unit = get_gfc_unit (dtp->common.unit, do_create); + unit->internal_reserved = true; set_internal_unit (dtp, unit, kind); fbuf_init (unit, 128); return unit; @@ -786,7 +815,7 @@ init_units (void) static int -close_unit_1 (gfc_unit *u, int locked) +close_unit_1 (gfc_unit *u, int locked, bool free_newunit) { int i, rc; @@ -816,7 +845,7 @@ close_unit_1 (gfc_unit *u, int locked) free_format_hash_table (u); fbuf_destroy (u); - if (u->unit_number <= NEWUNIT_START) + if (free_newunit && u->unit_number <= NEWUNIT_START) newunit_free (u->unit_number); if (!locked) @@ -852,7 +881,7 @@ unlock_unit (gfc_unit *u) int close_unit (gfc_unit *u) { - return close_unit_1 (u, 0); + return close_unit_1 (u, 0, true); } @@ -868,7 +897,7 @@ close_units (void) { WRLOCK (&unit_rwlock); while (unit_root != NULL) - close_unit_1 (unit_root, 1); + close_unit_1 (unit_root, 1, true); RWUNLOCK (&unit_rwlock); free (newunits);
