[PATCH] Fix PR119136 Printing result of function that prints itself hangs
Jerry D <[email protected]>
| Newsgroups | gmane.comp.gcc.patches,gmane.comp.gcc.fortran |
|---|---|
| Message-ID | <[email protected]> |
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.
pr119136-submit.diff
(text/x-patch, 4.5 KB)
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;