Hello all,
The attached patch fixes this by using the TRYLOCK to see if the UNIT is already
in use before proceeding with the I/O. Regression tested on x86_64-linux-gnu.
The idea triggered by Thomas in the PR.
OK for mainline?
Regards,
Jerry
Fortran: Generate a runtime error on recursive I/O
PR libfortran/119136
gcc/fortran/ChangeLog:
* libgfortran.h: Add enum for new LIBERROR_RECURSIVE_IO.
libgfortran/ChangeLog:
* io/io.h: Delete prototype for unused stash_internal_unit.
(check_for_recursive): Add prototype for this new function.
* io/transfer.c (data_transfer_init): Add call to new
check_for_recursive.
* io/unit.c (delete_unit): Fix comment.
(check_for_recursive): Add new function.
* runtime/error.c (translate_error): Add translation for
"Recursive I/O not allowed runtime error message.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr119136.f90: New test.commit b961b063f1700e8d88b0448a79c02460e87a2a6d
Author: Jerry DeLisle <[email protected]>
Date: Tue Dec 30 14:46:35 2025 -0800
Fortran: Generate a runtime error on recursive I/O
PR libfortran/119136
gcc/fortran/ChangeLog:
* libgfortran.h: Add enum for new LIBERROR_RECURSIVE_IO.
libgfortran/ChangeLog:
* io/io.h: Delete prototype for unused stash_internal_unit.
(check_for_recursive): Add prototype for this new function.
* io/transfer.c (data_transfer_init): Add call to new
check_for_recursive.
* io/unit.c (delete_unit): Fix comment.
(check_for_recursive): Add new function.
* runtime/error.c (translate_error): Add translation for
"Recursive I/O not allowed runtime error message.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr119136.f90: New test.
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 9de5afb6c83..ad3c697f279 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -143,6 +143,7 @@ typedef enum
LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE. */
LIBERROR_BAD_WAIT_ID,
LIBERROR_NO_MEMORY,
+ LIBERROR_RECURSIVE_IO,
LIBERROR_LAST /* Not a real error, the last error # + 1. */
}
libgfortran_error_codes;
diff --git a/gcc/testsuite/gfortran.dg/pr119136.f90 b/gcc/testsuite/gfortran.dg/pr119136.f90
new file mode 100644
index 00000000000..e579083b9b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr119136.f90
@@ -0,0 +1,10 @@
+! { dg-do run }
+! { dg-shouldfail "Recursive" }
+ print *, foo_io()
+contains
+ function foo_io()
+ integer :: foo_io(2)
+ print * , "foo"
+ foo_io = [42, 42]
+ end function
+end
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 798e760739c..2af6dd18841 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -782,8 +782,8 @@ internal_proto(close_unit);
extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
internal_proto(set_internal_unit);
-extern void stash_internal_unit (st_parameter_dt *);
-internal_proto(stash_internal_unit);
+extern void check_for_recursive (st_parameter_dt *dtp);
+internal_proto(check_for_recursive);
extern gfc_unit *find_unit (int);
internal_proto(find_unit);
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 3fc53938b4a..9152c648e86 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -3129,6 +3129,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
NOTE ("data_transfer_init");
+ check_for_recursive (dtp);
+
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index 62a8c514c18..2a4d9732697 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -324,8 +324,7 @@ delete_unit (gfc_unit *old)
}
/* get_gfc_unit_from_root()-- Given an integer, return a pointer
- to the unit structure. Returns NULL if the unit does not exist,
- otherwise returns a locked unit. */
+ to the unit structure. Returns NULL if the unit does not exist. */
static inline gfc_unit *
get_gfc_unit_from_unit_root (int n)
@@ -346,6 +345,30 @@ get_gfc_unit_from_unit_root (int n)
return p;
}
+/* Recursive I/O is not allowed. Check to see if the UNIT exists and if
+ so, check if the UNIT is locked already. This check does not apply
+ to DTIO. */
+void
+check_for_recursive (st_parameter_dt *dtp)
+{
+ gfc_unit *p;
+
+ p = get_gfc_unit_from_unit_root(dtp->common.unit);
+ if (p != NULL)
+ {
+ if (!(dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT))
+ {
+ /* The unit is external. */
+ if (TRYLOCK(&p->lock) && (p->child_dtio == 0))
+ {
+ generate_error (&dtp->common, LIBERROR_RECURSIVE_IO, NULL);
+ return;
+ }
+ UNLOCK(&p->lock);
+ }
+ }
+}
+
/* get_gfc_unit()-- Given an integer, return a pointer to the unit
structure. Returns NULL if the unit does not exist,
otherwise returns a locked unit. */
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index d2ae7be16f4..e1fafa6f07d 100644
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -633,6 +633,10 @@ translate_error (int code)
p = "Bad ID in WAIT statement";
break;
+ case LIBERROR_RECURSIVE_IO:
+ p = "Recursive I/O not allowed";
+ break;
+
default:
p = "Unknown error code";
break;
