Re: [patch, libfortran] Fix PR 123446, broken bootstrap

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/async.h b/libgfortran/io/async.h
index 76c087c554a..265f248950d 100644
--- a/libgfortran/io/async.h
+++ b/libgfortran/io/async.h
@@ -29,6 +29,9 @@
    __gthread_cond_t and __gthread_equal / __gthread_self.  Check
    this.  */
 
+/* #undef __GTHREADS_CXX0X - uncomment for checking non-threading
+   systems.  */
+
 #if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X)
 #define ASYNC_IO 1
 #else
@@ -42,6 +45,9 @@
 #undef DEBUG_ASYNC
 
 #ifdef DEBUG_ASYNC
+#ifndef __GTHREADS_CXX0X
+#error "gthreads support required for DEBUG_ASYNC"
+#endif
 
 /* Define this if you want to use ANSI color escape sequences in your
    debugging output.  */
@@ -175,6 +181,11 @@
     INTERN_UNLOCK (mutex);						\
   }while (0)
 
+#define UNLOCK_UNIT(unit) do { \
+  unit->self = 0;							\
+  UNLOCK(&(unit)->lock);						\
+  } while(0)
+
 #define TRYLOCK(mutex) ({						\
 			 char status[200];				\
 			 int res;					\
@@ -198,6 +209,30 @@
 			 res;						\
     })
 
+#define TRYLOCK_UNIT(unit) ({					\
+			 char status[200];				\
+			 int res;					\
+			 aio_lock_debug *curr;				\
+			 __gthread_mutex_t *mutex = &(unit)->lock;	\
+			 res = __gthread_mutex_trylock (mutex);		\
+			 INTERN_LOCK (&debug_queue_lock);		\
+			 if (res) {					\
+			   if ((curr = IN_DEBUG_QUEUE (mutex))) {	\
+			     sprintf (status, DEBUG_RED "%s():%d" DEBUG_NORM, curr->func, curr->line);	\
+			   } else					\
+			     sprintf (status, DEBUG_RED "unknown" DEBUG_NORM);	\
+			 }						\
+			 else {						\
+			   sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM);	\
+			   MUTEX_DEBUG_ADD (mutex);			\
+			 }						\
+			 DEBUG_PRINTF ("%s%-44s prev: %-35s %20s():%-5d %18p\n", aio_prefix, \
+				      DEBUG_DARKRED "TRYLOCK: " DEBUG_NORM #unit, status, __FUNCTION__, __LINE__, \
+				      (void *) mutex);			\
+			 INTERN_UNLOCK (&debug_queue_lock);		\
+			 res;						\
+    })
+
 #define LOCK(mutex) do {						\
     char status[200];							\
     CHECK_LOCK (mutex, status);						\
@@ -210,6 +245,12 @@
     DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
   } while (0)
 
+
+#define LOCK_UNIT(unit) do {		\
+    LOCK (&(unit)->lock);		\
+    (unit)->self = __gthread_self ();	\
+  } while (0)
+
 #ifdef __GTHREAD_RWLOCK_INIT
 #define RWLOCK_DEBUG_ADD(rwlock) do {		\
     aio_rwlock_debug *n;				\
@@ -334,15 +375,77 @@
 
 #define DEBUG_LINE(...) __VA_ARGS__
 
-#else
+#else  /* DEBUG_ASYNC */
+
 #define DEBUG_PRINTF(...) {}
 #define CHECK_LOCK(au, mutex, status) {}
 #define NOTE(str, ...) {}
 #define DEBUG_LINE(...)
 #define T_ERROR(func, ...) func(__VA_ARGS__)
 #define LOCK(mutex) INTERN_LOCK (mutex)
+
+#ifdef __GTHREADS_CXX0X
+
+/* When pthreads are not active, we do not touch the lock for locking /
+   unlocking; the only use for this is checking for recursion.  */
+
+#define LOCK_UNIT(unit) do {					\
+  if (__gthread_active_p ()) {					\
+    LOCK (&(unit)->lock); (unit)->self = __gthread_self ();	\
+  } else {							\
+    (unit)->self = 1;						\
+  }								\
+  } while(0)
+#else
+
+#define LOCK_UNIT(unit) do { \
+    (unit)->self = 1;	     \
+  } while(0)
+
+#endif
+
 #define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+
+#ifdef __GTHREADS_CXX0X
+
+#define UNLOCK_UNIT(unit) do {						\
+    if (__gthread_active_p ()) {					\
+      (unit)->self = 0 ; UNLOCK(&(unit)->lock);				\
+    } else {								\
+      (unit)->self = 0;							\
+    }									\
+} while(0)
+#else
+#define UNLOCK_UNIT(unit) do {			\
+    (unit)->self = 0;				\
+  } while(0)
+
+#endif
+
 #define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+
+#ifdef __GTHREADS_CXX0X
+#define TRYLOCK_UNIT(unit) ({					\
+      int res;							\
+      if (__gthread_active_p ()) {				\
+	res = __gthread_mutex_trylock (&(unit)->lock);		\
+	if (!res)						\
+	  (unit)->self = __gthread_self ();			\
+      }								\
+      else {							\
+	res = (unit)->self;					\
+	(unit)->self = 1;					\
+      }								\
+      res;							\
+    })
+#else
+#define TRYLOCK_UNIT(unit) ({ \
+      int res = (unit)->self; \
+      (unit)->self = 1;	      \
+      res;		      \
+    })
+#endif
+
 #ifdef __GTHREAD_RWLOCK_INIT
 #define RDLOCK(rwlock) INTERN_RDLOCK (rwlock)
 #define WRLOCK(rwlock) INTERN_WRLOCK (rwlock)
@@ -448,6 +551,15 @@ DEBUG_LINE (extern __gthread_rwlock_t debug_queue_rwlock;)
 extern __thread gfc_unit *thread_unit;
 #endif
 
+/* When threading is not active, or there is no thread system, we fake the ID
+   to be 1.  */
+
+#ifdef __GTHREADS_CXX0X
+#define OWN_THREAD_ID (__gthread_active_p () ? __gthread_self () : 1)
+#else
+#define OWN_THREAD_ID 1
+#endif
+
 enum aio_do {
   AIO_INVALID = 0,
   AIO_DATA_TRANSFER_INIT,
@@ -527,7 +639,7 @@ bool async_wait_id (st_parameter_common *, async_unit *, int);
 internal_proto (async_wait_id);
 
 bool collect_async_errors (st_parameter_common *, async_unit *);
-internal_proto (collect_async_errors); 
+internal_proto (collect_async_errors);
 
 void async_close (async_unit *);
 internal_proto (async_close);
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 798e760739c..029fb6b9414 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -728,6 +728,11 @@ typedef struct gfc_unit
   int last_char;
   bool has_size;
   GFC_IO_INT size_used;
+#ifdef __GTHREADS_CXX0X
+  __gthread_t self;
+#else
+  int self;
+#endif
 }
 gfc_unit;
 
@@ -782,8 +787,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..8cf85f6fb15 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -247,7 +247,7 @@ insert_unit (int n)
 #else
   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
 #endif
-  LOCK (&u->lock);
+  LOCK_UNIT (u);
   u->priority = pseudo_random ();
   unit_root = insert (u, unit_root);
   return u;
@@ -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,42 @@ 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_UNIT(p))
+		{
+		  /* The lock failed.  This unit is locked either our own
+		     thread, which is illegal recursive I/O, or somebody by
+		     else, in which case we are doing OpenMP or similar; this
+		     is harmless and permitted.  When threading is not active, or
+		     there is no thread system, we fake the ID to be 1.  */
+		  if (__atomic_load_n (&p->self, __ATOMIC_RELAXED) == OWN_THREAD_ID)
+		    generate_error (&dtp->common, LIBERROR_RECURSIVE_IO, NULL);
+		  return;
+		}
+	      else
+		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. */
@@ -412,7 +447,7 @@ found:
   if (p != NULL && (p->child_dtio == 0))
     {
       /* Fast path.  */
-      if (! TRYLOCK (&p->lock))
+      if (! TRYLOCK_UNIT (p))
 	{
 	  /* assert (p->closed == 0); */
 	  RWUNLOCK (&unit_rwlock);
@@ -427,11 +462,11 @@ found:
 
   if (p != NULL && (p->child_dtio == 0))
     {
-      LOCK (&p->lock);
+      LOCK_UNIT (p);
       if (p->closed)
 	{
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&p->lock);
+	  UNLOCK_UNIT (p);
 	  if (predec_waiting_locked (p) == 0)
 	    destroy_unit_mutex (p);
 	  goto retry;
@@ -678,7 +713,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
 
   if (options.stdout_unit >= 0)
@@ -709,7 +744,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
 
   if (options.stderr_unit >= 0)
@@ -740,13 +775,13 @@ init_units (void)
       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
                               any kind of exotic formatting to stderr.  */
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
   /* The default internal units.  */
   u = insert_unit (GFC_INTERNAL_UNIT);
-  UNLOCK (&u->lock);
+  UNLOCK_UNIT (u);
   u = insert_unit (GFC_INTERNAL_UNIT4);
-  UNLOCK (&u->lock);
+  UNLOCK_UNIT (u);
 }
 
 
@@ -785,7 +820,7 @@ close_unit_1 (gfc_unit *u, int locked)
     newunit_free (u->unit_number);
 
   if (!locked)
-    UNLOCK (&u->lock);
+    UNLOCK_UNIT (u);
 
   /* If there are any threads waiting in find_unit for this unit,
      avoid freeing the memory, the last such thread will free it
@@ -805,7 +840,7 @@ unlock_unit (gfc_unit *u)
   if (u)
     {
       NOTE ("unlock_unit = %d", u->unit_number);
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
       NOTE ("unlock_unit done");
     }
 }
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
index 129e2dbf091..4a28ec8c615 100644
--- a/libgfortran/io/unix.c
+++ b/libgfortran/io/unix.c
@@ -1791,11 +1791,11 @@ retry:
   RWUNLOCK (&unit_rwlock);
   if (u != NULL)
     {
-      LOCK (&u->lock);
+      LOCK_UNIT (u);
       if (u->closed)
 	{
 	  RDLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	  goto retry;
@@ -1825,7 +1825,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
 	    return u;
 	  if (u->s)
 	    sflush (u->s);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	}
       u = u->right;
     }
@@ -1848,7 +1848,7 @@ flush_all_units (void)
       if (u == NULL)
 	return;
 
-      LOCK (&u->lock);
+      LOCK_UNIT (u);
 
       min_unit = u->unit_number + 1;
 
@@ -1856,13 +1856,13 @@ flush_all_units (void)
 	{
 	  sflush (u->s);
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  (void) predec_waiting_locked (u);
 	}
       else
 	{
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	}
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;