https://gcc.gnu.org/g:489423763d3c8b84d3409f4b200fb6b19ad96db3
commit r16-6459-g489423763d3c8b84d3409f4b200fb6b19ad96db3 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: --- gcc/fortran/libgfortran.h | 1 + gcc/testsuite/gfortran.dg/pr119136.f90 | 10 ++++++++++ libgfortran/io/io.h | 4 ++-- libgfortran/io/transfer.c | 2 ++ libgfortran/io/unit.c | 31 +++++++++++++++++++++++++++++-- libgfortran/runtime/error.c | 4 ++++ 6 files changed, 48 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9de5afb6c83e..ad3c697f2790 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 000000000000..e579083b9b6a --- /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 798e760739c8..2af6dd188411 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 3fc53938b4a2..9152c648e865 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 62a8c514c186..6bd3acf09e9e 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,34 @@ 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 p is external. */ + { + /* Check if this is a parent I/O. */ + if (p->child_dtio == 0) + { + if (TRYLOCK(&p->lock)) + { + 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 d2ae7be16f41..e1fafa6f07d1 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;
