See attached patch.
Regression tested on x86_64.
OK for mainline.
Regards,
Jerry
---
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.
commit e9078a638c1bb7f54f702db22a231e3adc71efc6
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.
diff --git a/gcc/testsuite/gfortran.dg/pr126116.f90 b/gcc/testsuite/gfortran.dg/pr126116.f90
new file mode 100644
index 00000000000..420584e07df
--- /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 ade0bef32d5..ecf1b779a48 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -535,7 +535,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
@@ -649,7 +649,7 @@ typedef struct gfc_unit
{
int unit_number;
stream *s;
-
+
/* Treap links. */
struct gfc_unit *left, *right;
int priority;
@@ -709,10 +709,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);
@@ -723,6 +723,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;
@@ -1023,7 +1026,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 84acfbdff98..ed40fd58b80 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -479,17 +479,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;
}
@@ -625,6 +653,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;
@@ -787,7 +816,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;
@@ -817,7 +846,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)
@@ -853,7 +882,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);
}
@@ -869,7 +898,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);
