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 9de5afb6c83e1069f2c9c7827df0e6988a764fd1..ad3c697f2790048c80496c8695ddd27ffe09e27c 100644 (file)
--- 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 (file)
index 0000000..e579083
--- /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 798e760739c8d8a8571e297620ee7dfda7f5f188..2af6dd188411e7c732c0658af40f714bd9821a17 100644 (file)
--- 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 3fc53938b4a23b8806da4b37f5e81cc5b66432dd..9152c648e865e6acc9cbe6338e8b3bbbc13f8280 100644 (file)
--- 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 62a8c514c18616a45e49fedd879b2c4b661a5a32..6bd3acf09e9e2f2559cc77c5db264ce826134c02 100644 (file)
--- 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 d2ae7be16f41e96f2b57b4342ecde6b8ebaa72b6..e1fafa6f07d15430b3175e2e8379efb76432fcae 100644 (file)
--- 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;