Async I/O patch with compilation fix

[Nicolas Koenig <koenigni at student dot ethz dot ch>]

Hello everyone,

Here is an updated version of the patch that hopefully fixes the compilation
problems by disabling async I/O if conditions are not supported by the target.

I would appreciate if people could test it on systems on which it failed 
before. As for the array_constructor_8.f90 failure reported in the PR, why
it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
unrelated?

	Nicolas


2018-08-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
	Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/25829
	* gfortran.texi: Add description of asynchronous I/O.
	* trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
	as volatile.
	* trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
	st_wait_async and change argument spec from ".X" to ".w".
	(gfc_trans_wait): Pass ID argument via reference.

2018-08-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
	Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/25829
	* gfortran.dg/f2003_inquire_1.f03: Add write statement.
	* gfortran.dg/f2003_io_1.f03: Add wait statement.

2018-08-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
	Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/25829
	* Makefile.am: Add async.c to gfor_io_src.
	Add async.h to gfor_io_headers.
	* Makefile.in: Regenerated.
	* gfortran.map: Add _gfortran_st_wait_async.
	* io/async.c: New file.
	* io/async.h: New file.
	* io/close.c: Include async.h.
	(st_close): Call async_wait for an asynchronous unit.
	* io/file_pos.c (st_backspace): Likewise.
	(st_endfile): Likewise.
	(st_rewind): Likewise.
	(st_flush): Likewise.
	* io/inquire.c: Add handling for asynchronous PENDING
	and ID arguments.
	* io/io.h (st_parameter_dt): Add async bit.
	(st_parameter_wait): Correct.
	(gfc_unit): Add au pointer.
	(st_wait_async): Add prototype.
	(transfer_array_inner): Likewise.
	(st_write_done_worker): Likewise.
	* io/open.c: Include async.h.
	(new_unit): Initialize asynchronous unit.
	* io/transfer.c (async_opt): New struct.
	(wrap_scalar_transfer): New function.
	(transfer_integer): Call wrap_scalar_transfer to do the work.
	(transfer_real): Likewise.
	(transfer_real_write): Likewise.
	(transfer_character): Likewise.
	(transfer_character_wide): Likewise.
	(transfer_complex): Likewise.
	(transfer_array_inner): New function.
	(transfer_array): Call transfer_array_inner.
	(transfer_derived): Call wrap_scalar_transfer.
	(data_transfer_init): Check for asynchronous I/O.
	Perform a wait operation on any pending asynchronous I/O
	if the data transfer is synchronous. Copy PDT and enqueue
	thread for data transfer.
	(st_read_done_worker): New function.
	(st_read_done): Enqueue transfer or call st_read_done_worker.
	(st_write_done_worker): New function.
	(st_write_done): Enqueue transfer or call st_read_done_worker.
	(st_wait): Document as no-op for compatibility reasons.
	(st_wait_async): New function.
	* io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
	add NOTE where necessary.
	(get_gfc_unit): Likewise.
	(init_units): Likewise.
	(close_unit_1): Likewise. Call async_close if asynchronous.
	(close_unit): Use macros LOCK and UNLOCK.
	(finish_last_advance_record): Likewise.
	(newunit_alloc): Likewise.
	* io/unix.c (find_file): Likewise.
	(flush_all_units_1): Likewise.
	(flush_all_units): Likewise.
	* libgfortran.h (generate_error_common): Add prototype.
	* runtime/error.c: Include io.h and async.h.
	(generate_error_common): New function.

2018-08-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
	Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/25829
	* testsuite/libgomp.fortran/async_io_1.f90: New test.
	* testsuite/libgomp.fortran/async_io_2.f90: New test.
	* testsuite/libgomp.fortran/async_io_3.f90: New test.
	* testsuite/libgomp.fortran/async_io_4.f90: New test.
	* testsuite/libgomp.fortran/async_io_5.f90: New test.
	* testsuite/libgomp.fortran/async_io_6.f90: New test.
	* testsuite/libgomp.fortran/async_io_7.f90: New test.

Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi	(revision 263244)
+++ gcc/fortran/gfortran.texi	(working copy)
@@ -879,8 +879,7 @@ than @code{(/.../)}.  Type-specification for array
 @item Extensions to the specification and initialization expressions,
 including the support for intrinsics with real and complex arguments.
 
-@item Support for the asynchronous input/output syntax; however, the
-data transfer is currently always synchronously performed. 
+@item Support for the asynchronous input/output.
 
 @item
 @cindex @code{FLUSH} statement
@@ -1183,6 +1182,7 @@ might in some way or another become visible to the
 * Files opened without an explicit ACTION= specifier::
 * File operations on symbolic links::
 * File format of unformatted sequential files::
+* Asynchronous I/O::
 @end menu
 
 
@@ -1486,6 +1486,20 @@ program main
 end program main
 @end smallexample
 
+@node Asynchronous I/O
+@section Asynchronous I/O
+@cindex input/output, asynchronous
+@cindex asynchronous I/O
+
+Asynchronous I/O is supported if the program is linked against the
+POSIX thread library. If that is not the case, all I/O is performed
+as synchronous.
+
+On some systems, such as Darwin or Solaris, the POSIX thread library
+is always linked in, so asynchronous I/O is always performed. On other
+sytems, such as Linux, it is necessary to specify @option{-pthread},
+@option{-lpthread} or @option{-fopenmp} during the linking step.
+
 @c ---------------------------------------------------------------------
 @c Extensions
 @c ---------------------------------------------------------------------
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 263244)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -698,7 +698,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 	      && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
     TREE_STATIC (decl) = 1;
 
-  if (sym->attr.volatile_)
+  /* Treat asynchronous variables the same as volatile, for now.  */
+  if (sym->attr.volatile_ || sym->attr.asynchronous)
     {
       TREE_THIS_VOLATILE (decl) = 1;
       TREE_SIDE_EFFECTS (decl) = 1;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(revision 263244)
+++ gcc/fortran/trans-io.c	(working copy)
@@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void)
 	get_identifier (PREFIX("st_iolength")), ".w",
 	void_type_node, 1, dt_parm_type);
 
-  /* TODO: Change when asynchronous I/O is implemented.  */
   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
   iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("st_wait")), ".X",
+	get_identifier (PREFIX("st_wait_async")), ".w",
 	void_type_node, 1, parm_type);
 
   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
@@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code)
     mask |= IOPARM_common_err;
 
   if (p->id)
-    mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
 
   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 
Index: gcc/testsuite/gfortran.dg/f2003_inquire_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_inquire_1.f03	(revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03	(working copy)
@@ -7,10 +7,12 @@ logical :: vpending
 open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", &
 & decimal="comma", encoding="utf-8", sign="plus")
 
+write (10,*, asynchronous="yes", id=vid) 'asdf'
+wait (10)
+
 inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, &
 & pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, &
 & encoding=sencoding)
-
 if (ssign.ne."PLUS") STOP 1
 if (sasynchronous.ne."YES") STOP 2
 if (sdecimal.ne."COMMA") STOP 3
Index: gcc/testsuite/gfortran.dg/f2003_io_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_1.f03	(revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03	(working copy)
@@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="y
 write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a
 rewind(10)
 read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b
+wait(10)
 if (any(b.ne.23.45)) STOP 1
 
 c = 3.14
@@ -24,6 +25,7 @@ rewind(10)
 write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
 rewind(10)
 read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
+wait (10)
 if (any(b.ne.23.45)) STOP 3
 
 wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j)
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am	(revision 263244)
+++ libgfortran/Makefile.am	(working copy)
@@ -100,7 +100,8 @@ io/transfer128.c \
 io/unit.c \
 io/unix.c \
 io/write.c \
-io/fbuf.c
+io/fbuf.c \
+io/async.c
 
 endif
 
@@ -108,7 +109,8 @@ gfor_io_headers= \
 io/io.h \
 io/fbuf.h \
 io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
 
 gfor_helper_src= \
 intrinsics/associated.c \
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in	(revision 263244)
+++ libgfortran/Makefile.in	(working copy)
@@ -70,7 +70,8 @@ target_triplet = @target@
 @LIBGFOR_MINIMAL_FALSE@io/unit.c \
 @LIBGFOR_MINIMAL_FALSE@io/unix.c \
 @LIBGFOR_MINIMAL_FALSE@io/write.c \
-@LIBGFOR_MINIMAL_FALSE@io/fbuf.c
+@LIBGFOR_MINIMAL_FALSE@io/fbuf.c \
+@LIBGFOR_MINIMAL_FALSE@io/async.c
 
 @LIBGFOR_MINIMAL_FALSE@am__append_3 = \
 @LIBGFOR_MINIMAL_FALSE@intrinsics/access.c \
@@ -352,7 +353,7 @@ am__objects_47 = $(am__objects_4) $(am__objects_5)
 @LIBGFOR_MINIMAL_FALSE@	inquire.lo intrinsics.lo list_read.lo \
 @LIBGFOR_MINIMAL_FALSE@	lock.lo open.lo read.lo transfer.lo \
 @LIBGFOR_MINIMAL_FALSE@	transfer128.lo unit.lo unix.lo write.lo \
-@LIBGFOR_MINIMAL_FALSE@	fbuf.lo
+@LIBGFOR_MINIMAL_FALSE@	fbuf.lo async.lo
 am__objects_49 = size_from_kind.lo $(am__objects_48)
 @LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
 @LIBGFOR_MINIMAL_FALSE@	chdir.lo chmod.lo clock.lo cpu_time.lo \
@@ -650,7 +651,8 @@ gfor_io_headers = \
 io/io.h \
 io/fbuf.h \
 io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
 
 gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
 	intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
@@ -1551,6 +1553,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@
@@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c
 @AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c
 
+async.lo: io/async.c
+@am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+@am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+
 associated.lo: intrinsics/associated.c
 @am__fastdepCC_TRUE@	$(LIBTOOL)  --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
 @am__fastdepCC_TRUE@	$(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 263244)
+++ libgfortran/gfortran.map	(working copy)
@@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 {
     y1f;
     ynf;
 };
+
+GFORTRAN_9 {
+  global:
+  _gfortran_st_wait_async;
+};
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c	(revision 263244)
+++ libgfortran/io/close.c	(working copy)
@@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 
 #include "io.h"
 #include "unix.h"
+#include "async.h"
 #include <limits.h>
 
 typedef enum
@@ -57,6 +58,15 @@ st_close (st_parameter_close *clp)
     find_option (&clp->common, clp->status, clp->status_len,
 		 status_opt, "Bad STATUS parameter in CLOSE statement");
 
+  u = find_unit (clp->common.unit);
+
+  if (ASYNC_IO && u && u->au)
+    if (async_wait (&(clp->common), u->au))
+      {
+	library_end ();
+	return;
+      }
+
   if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
   {
     library_end ();
@@ -63,7 +73,6 @@ st_close (st_parameter_close *clp)
     return;
   }
 
-  u = find_unit (clp->common.unit);
   if (u != NULL)
     {
       if (close_share (u) < 0)
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c	(revision 263244)
+++ libgfortran/io/file_pos.c	(working copy)
@@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include "io.h"
 #include "fbuf.h"
 #include "unix.h"
+#include "async.h"
 #include <string.h>
 
 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
@@ -187,6 +188,7 @@ void
 st_backspace (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
+  bool needs_unlock = false;
 
   library_start (&fpp->common);
 
@@ -214,6 +216,17 @@ st_backspace (st_parameter_filepos *fpp)
       goto done;
     }
 
+  if (ASYNC_IO && u->au)
+    {
+      if (async_wait (&(fpp->common), u->au))
+	return;
+      else
+	{
+	  needs_unlock = true;
+	  LOCK (&u->au->io_lock);
+	}
+    }
+
   /* Make sure format buffer is flushed and reset.  */
   if (u->flags.form == FORM_FORMATTED)
     {
@@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp)
 
  done:
   if (u != NULL)
-    unlock_unit (u);
+    {
+      unlock_unit (u);
 
+      if (ASYNC_IO && u->au && needs_unlock)
+	UNLOCK (&u->au->io_lock);
+    }
+
   library_end ();
 }
 
@@ -280,6 +298,7 @@ void
 st_endfile (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
+  bool needs_unlock = false;
 
   library_start (&fpp->common);
 
@@ -294,6 +313,17 @@ st_endfile (st_parameter_filepos *fpp)
 	  goto done;
 	}
 
+      if (ASYNC_IO && u->au)
+	{
+	  if (async_wait (&(fpp->common), u->au))
+	    return;
+	  else
+	    {
+	      needs_unlock = true;
+	      LOCK (&u->au->io_lock);
+	    }
+	}
+
       if (u->flags.access == ACCESS_SEQUENTIAL
       	  && u->endfile == AFTER_ENDFILE)
 	{
@@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp)
 	}
     }
 
-  done:
-    unlock_unit (u);
+ done:
+  if (ASYNC_IO && u->au && needs_unlock)
+    UNLOCK (&u->au->io_lock);
 
+  unlock_unit (u);
+
   library_end ();
 }
 
@@ -390,6 +423,7 @@ void
 st_rewind (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
+  bool needs_unlock = true;
 
   library_start (&fpp->common);
 
@@ -401,6 +435,17 @@ st_rewind (st_parameter_filepos *fpp)
 			"Cannot REWIND a file opened for DIRECT access");
       else
 	{
+	  if (ASYNC_IO && u->au)
+	    {
+	      if (async_wait (&(fpp->common), u->au))
+		return;
+	      else
+		{
+		  needs_unlock = true;
+		  LOCK (&u->au->io_lock);
+		}
+	    }
+
 	  /* If there are previously written bytes from a write with ADVANCE="no",
 	     add a record marker before performing the ENDFILE.  */
 
@@ -436,6 +481,10 @@ st_rewind (st_parameter_filepos *fpp)
 	}
       /* Update position for INQUIRE.  */
       u->flags.position = POSITION_REWIND;
+
+      if (ASYNC_IO && u->au && needs_unlock)
+	UNLOCK (&u->au->io_lock);
+
       unlock_unit (u);
     }
 
@@ -450,6 +499,7 @@ void
 st_flush (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
+  bool needs_unlock = false;
 
   library_start (&fpp->common);
 
@@ -456,6 +506,17 @@ st_flush (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
+      if (ASYNC_IO && u->au)
+	{
+	  if (async_wait (&(fpp->common), u->au))
+	    return;
+	  else
+	    {
+	      needs_unlock = true;
+	      LOCK (&u->au->io_lock);
+	    }
+	}
+
       /* Make sure format buffer is flushed.  */
       if (u->flags.form == FORM_FORMATTED)
         fbuf_flush (u, u->mode);
@@ -469,5 +530,8 @@ st_flush (st_parameter_filepos *fpp)
     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 			"Specified UNIT in FLUSH is not connected");
 
+  if (needs_unlock)
+    UNLOCK (&u->au->io_lock);
+
   library_end ();
 }
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c	(revision 263244)
+++ libgfortran/io/inquire.c	(working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 /* Implement the non-IOLENGTH variant of the INQUIRY statement */
 
 #include "io.h"
+#include "async.h"
 #include "unix.h"
 #include <string.h>
 
@@ -281,12 +282,6 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
     {
       GFC_INTEGER_4 cf2 = iqp->flags2;
 
-      if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
-	*iqp->pending = 0;
-  
-      if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
-        *iqp->id = 0;
-
       if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
 	{
 	  if (u == NULL || u->flags.form != FORM_FORMATTED)
@@ -332,21 +327,43 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
 	  if (u == NULL)
 	    p = undefined;
 	  else
-	    switch (u->flags.async)
 	    {
-	      case ASYNC_YES:
-		p = yes;
-		break;
-	      case ASYNC_NO:
-		p = no;
-		break;
-	      default:
-		internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+	      switch (u->flags.async)
+		{
+		case ASYNC_YES:
+		  p = yes;
+		  break;
+		case ASYNC_NO:
+		  p = no;
+		  break;
+		default:
+		  internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+		}
 	    }
-
 	  cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
 	}
 
+      if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+	{
+	  if (!ASYNC_IO || u->au == NULL)
+	    *(iqp->pending) = 0;
+	  else
+	    {
+	      LOCK (&(u->au->lock));
+	      if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+		{
+		  int id;
+		  id = *(iqp->id);
+		  *(iqp->pending) = id > u->au->id.low;
+		}
+	      else
+		{
+		  *(iqp->pending) = ! u->au->empty;
+		}
+	      UNLOCK (&(u->au->lock));
+	    }
+	}
+
       if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
 	{
 	  if (u == NULL)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 263244)
+++ libgfortran/io/io.h	(working copy)
@@ -531,7 +531,9 @@ typedef struct st_parameter_dt
 	  /* A flag used to identify when a non-standard expanded namelist read
 	     has occurred.  */
 	  unsigned expanded_read : 1;
-	  /* 13 unused bits.  */
+	  /* Flag to indicate if the statement has async="YES". */
+	  unsigned async : 1;
+	  /* 12 unused bits.  */
 
 	  int child_saved_iostat;
 	  int nml_delim;
@@ -590,7 +592,7 @@ extern char check_st_parameter_dt[sizeof (((st_par
 typedef struct
 {
   st_parameter_common common;
-  CHARACTER1 (id);
+  GFC_INTEGER_4 *id;
 }
 st_parameter_wait;
 
@@ -659,6 +661,9 @@ typedef struct gfc_unit
 
   int continued;
 
+  /* Contains the pointer to the async unit.  */
+  struct async_unit *au;
+
   __gthread_mutex_t lock;
   /* Number of threads waiting to acquire this unit's lock.
      When non-zero, close_unit doesn't only removes the unit
@@ -815,11 +820,18 @@ extern void next_record (st_parameter_dt *, int);
 internal_proto(next_record);
 
 extern void st_wait (st_parameter_wait *);
-export_proto(st_wait);
+export_proto (st_wait);
 
+extern void st_wait_async (st_parameter_wait *);
+export_proto (st_wait_async);
+
 extern void hit_eof (st_parameter_dt *);
 internal_proto(hit_eof);
 
+extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
+				  gfc_charlen_type);
+internal_proto (transfer_array_inner);
+
 /* read.c */
 
 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
@@ -988,3 +1000,14 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
 
 #endif
 
+extern void
+st_write_done_worker (st_parameter_dt *);
+internal_proto (st_write_done_worker);
+
+extern void
+st_read_done_worker (st_parameter_dt *);
+internal_proto (st_read_done_worker);
+
+extern void
+data_transfer_init_worker (st_parameter_dt *, int);
+internal_proto (data_transfer_init_worker);
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c	(revision 263244)
+++ libgfortran/io/open.c	(working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include "io.h"
 #include "fbuf.h"
 #include "unix.h"
+#include "async.h"
 
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
@@ -651,8 +652,12 @@ new_unit (st_parameter_open *opp, gfc_unit *u, uni
   else
     u->fbuf = NULL;
 
-    
-    
+  /* Check if asynchrounous.  */
+  if (flags->async == ASYNC_YES)
+    init_async_unit (u);
+  else
+    u->au = NULL;
+
   return u;
 
  cleanup:
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c	(revision 263244)
+++ libgfortran/io/read.c	(working copy)
@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include <string.h>
 #include <ctype.h>
 #include <assert.h>
+#include "async.h"
 
 typedef unsigned char uchar;
 
@@ -42,6 +43,7 @@ typedef unsigned char uchar;
 void
 set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
 {
+  NOTE ("set_integer: %lld %p", (long long int) value, dest);
   switch (length)
     {
 #ifdef HAVE_GFC_INTEGER_16
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c	(revision 263244)
+++ libgfortran/io/transfer.c	(working copy)
@@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include "fbuf.h"
 #include "format.h"
 #include "unix.h"
+#include "async.h"
 #include <string.h>
 #include <errno.h>
 
@@ -184,6 +185,12 @@ static const st_option pad_opt[] = {
   {NULL, 0}
 };
 
+static const st_option async_opt[] = {
+  {"yes", ASYNC_YES},
+  {"no", ASYNC_NO},
+  {NULL, 0}
+};
+
 typedef enum
 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
   FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -1594,7 +1601,8 @@ formatted_transfer_scalar_read (st_parameter_dt *d
 		read_f (dtp, f, p, kind);
 		break;
 	      default:
-		internal_error (&dtp->common, "formatted_transfer(): Bad type");
+		internal_error (&dtp->common,
+				"formatted_transfer (): Bad type");
 	    }
 	  break;
 
@@ -2066,7 +2074,7 @@ formatted_transfer_scalar_write (st_parameter_dt *
 		break;
 	      default:
 		internal_error (&dtp->common,
-				"formatted_transfer(): Bad type");
+				"formatted_transfer (): Bad type");
 	    }
 	  break;
 
@@ -2281,7 +2289,39 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
     }
 }
 
+/* Wrapper function for I/O of scalar types.  If this should be an async I/O
+   request, queue it.  For a synchronous write on an async unit, perform the
+   wait operation and return an error.  For all synchronous writes, call the
+   right transfer function.  */
 
+static void
+wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+		      size_t size, size_t n_elem)
+{
+  if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+    {
+      if (dtp->u.p.async)
+	{
+	  transfer_args args;
+	  args.scalar.transfer = dtp->u.p.transfer;
+	  args.scalar.arg_bt = type;
+	  args.scalar.data = p;
+	  args.scalar.i = kind;
+	  args.scalar.s1 = size;
+	  args.scalar.s2 = n_elem;
+	  enqueue_transfer (dtp->u.p.current_unit->au, &args,
+			    AIO_TRANSFER_SCALAR);
+	  return;
+	}
+    }
+  /* Come here if there was no asynchronous I/O to be scheduled.  */
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  dtp->u.p.transfer (dtp, type, p, kind, size, 1);
+}
+
+
 /* Data transfer entry points.  The type of the data entity is
    implicit in the subroutine call.  This prevents us from having to
    share a common enum with the compiler.  */
@@ -2289,9 +2329,7 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
 void
 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
 {
-  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
-    return;
-  dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
+    wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
 }
 
 void
@@ -2307,7 +2345,7 @@ transfer_real (st_parameter_dt *dtp, void *p, int
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     return;
   size = size_from_real_kind (kind);
-  dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
+  wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
 }
 
 void
@@ -2319,9 +2357,7 @@ transfer_real_write (st_parameter_dt *dtp, void *p
 void
 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
 {
-  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
-    return;
-  dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
+  wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
 }
 
 void
@@ -2345,7 +2381,7 @@ transfer_character (st_parameter_dt *dtp, void *p,
     p = empty_string;
 
   /* Set kind here to 1.  */
-  dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+  wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
 }
 
 void
@@ -2369,7 +2405,7 @@ transfer_character_wide (st_parameter_dt *dtp, voi
     p = empty_string;
 
   /* Here we pass the actual kind value.  */
-  dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
+  wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
 }
 
 void
@@ -2385,7 +2421,7 @@ transfer_complex (st_parameter_dt *dtp, void *p, i
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     return;
   size = size_from_complex_kind (kind);
-  dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
+  wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
 }
 
 void
@@ -2395,8 +2431,8 @@ transfer_complex_write (st_parameter_dt *dtp, void
 }
 
 void
-transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
-		gfc_charlen_type charlen)
+transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+		      gfc_charlen_type charlen)
 {
   index_type count[GFC_MAX_DIMENSIONS];
   index_type extent[GFC_MAX_DIMENSIONS];
@@ -2407,7 +2443,7 @@ void
   bt iotype;
 
   /* Adjust item_count before emitting error message.  */
- 
+
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     return;
 
@@ -2471,6 +2507,36 @@ void
 }
 
 void
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+	        gfc_charlen_type charlen)
+{
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    return;
+
+  if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+    {
+      if (dtp->u.p.async)
+	{
+	  transfer_args args;
+	  size_t sz = sizeof (gfc_array_char)
+			+ sizeof (descriptor_dimension)
+       			* GFC_DESCRIPTOR_RANK (desc);
+	  args.array.desc = xmalloc (sz);
+	  NOTE ("desc = %p", (void *) args.array.desc);
+	  memcpy (args.array.desc, desc, sz);
+	  args.array.kind = kind;
+	  args.array.charlen = charlen;
+	  enqueue_transfer (dtp->u.p.current_unit->au, &args,
+			    AIO_TRANSFER_ARRAY);
+	  return;
+	}
+    }
+  /* Come here if there was no asynchronous I/O to be scheduled.  */
+  transfer_array_inner (dtp, desc, kind, charlen);
+}
+
+
+void
 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
 		      gfc_charlen_type charlen)
 {
@@ -2492,7 +2558,7 @@ transfer_derived (st_parameter_dt *parent, void *d
       else
 	parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
     }
-  parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+  wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
 }
 
 
@@ -2667,7 +2733,10 @@ data_transfer_init (st_parameter_dt *dtp, int read
   unit_flags u_flags;  /* Used for creating a unit if needed.  */
   GFC_INTEGER_4 cf = dtp->common.flags;
   namelist_info *ionml;
+  async_unit *au;
 
+  NOTE ("data_transfer_init");
+
   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
 
   memset (&dtp->u.p, 0, sizeof (dtp->u.p));
@@ -2693,9 +2762,9 @@ data_transfer_init (st_parameter_dt *dtp, int read
     }
   else if (dtp->u.p.current_unit->s == NULL)
     {  /* Open the unit with some default flags.  */
-       st_parameter_open opp;
-       unit_convert conv;
-
+      st_parameter_open opp;
+      unit_convert conv;
+      NOTE ("Open the unit with some default flags.");
       memset (&u_flags, '\0', sizeof (u_flags));
       u_flags.access = ACCESS_SEQUENTIAL;
       u_flags.action = ACTION_READWRITE;
@@ -2770,6 +2839,42 @@ data_transfer_init (st_parameter_dt *dtp, int read
   else if (dtp->u.p.current_unit->internal_unit_kind > 0)
     dtp->u.p.unit_is_internal = 1;
 
+  if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
+    {
+      int f;
+      f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
+		       async_opt, "Bad ASYNCHRONOUS in data transfer "
+		       "statement");
+      if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
+	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			  "ASYNCHRONOUS transfer without "
+			  "ASYHCRONOUS='YES' in OPEN");
+	  return;
+	}
+      dtp->u.p.async = f == ASYNC_YES;
+    }
+
+  au = dtp->u.p.current_unit->au;
+  if (au)
+    {
+      if (dtp->u.p.async)
+	{
+	  /* If this is an asynchronous I/O statement, collect errors and
+	     return if there are any.  */
+	  if (collect_async_errors (&dtp->common, au))
+	    return;
+	}
+      else
+	{
+	  /* Synchronous statement: Perform a wait operation for any pending
+	     asynchronous I/O.  This needs to be done before all other error
+	     checks.  See F2008, 9.6.4.1.  */
+	  if (async_wait (&(dtp->common), au))
+	    return;
+	}
+    }
+
   /* Check the action.  */
 
   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@@ -3009,6 +3114,57 @@ data_transfer_init (st_parameter_dt *dtp, int read
   if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
 	dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
 
+  /* Set up the subroutine that will handle the transfers.  */
+
+  if (read_flag)
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+	dtp->u.p.transfer = unformatted_read;
+      else
+	{
+	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+	    dtp->u.p.transfer = list_formatted_read;
+	  else
+	    dtp->u.p.transfer = formatted_transfer;
+	}
+    }
+  else
+    {
+      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+	dtp->u.p.transfer = unformatted_write;
+      else
+	{
+	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+	    dtp->u.p.transfer = list_formatted_write;
+	  else
+	    dtp->u.p.transfer = formatted_transfer;
+	}
+    }
+
+  if (au)
+    {
+      NOTE ("enqueue_data_transfer");
+      enqueue_data_transfer_init (au, dtp, read_flag);
+    }
+  else
+    {
+      NOTE ("invoking data_transfer_init_worker");
+      data_transfer_init_worker (dtp, read_flag);
+    }
+}
+
+void
+data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
+{
+  GFC_INTEGER_4 cf = dtp->common.flags;
+
+  NOTE ("starting worker...");
+
+  if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED
+      && ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+      && dtp->u.p.current_unit->child_dtio  == 0)
+    dtp->u.p.current_unit->last_char = EOF - 1;
+
   /* Check to see if we might be reading what we wrote before  */
 
   if (dtp->u.p.mode != dtp->u.p.current_unit->mode
@@ -3135,38 +3291,6 @@ data_transfer_init (st_parameter_dt *dtp, int read
 
   pre_position (dtp);
 
-
-  /* Set up the subroutine that will handle the transfers.  */
-
-  if (read_flag)
-    {
-      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
-	dtp->u.p.transfer = unformatted_read;
-      else
-	{
-	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
-	    {
-	      if (dtp->u.p.current_unit->child_dtio  == 0)
-	        dtp->u.p.current_unit->last_char = EOF - 1;
-	      dtp->u.p.transfer = list_formatted_read;
-	    }
-	  else
-	    dtp->u.p.transfer = formatted_transfer;
-	}
-    }
-  else
-    {
-      if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
-	dtp->u.p.transfer = unformatted_write;
-      else
-	{
-	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
-	    dtp->u.p.transfer = list_formatted_write;
-	  else
-	    dtp->u.p.transfer = formatted_transfer;
-	}
-    }
-
   /* Make sure that we don't do a read after a nonadvancing write.  */
 
   if (read_flag)
@@ -4099,7 +4223,7 @@ extern void st_read_done (st_parameter_dt *);
 export_proto(st_read_done);
 
 void
-st_read_done (st_parameter_dt *dtp)
+st_read_done_worker (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
 
@@ -4127,6 +4251,30 @@ void
 	  free_format_data (dtp->u.p.fmt);
 	  free_format (dtp);
 	}
+    }
+}
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.current_unit)
+    {
+      if (dtp->u.p.current_unit->au)
+	{
+	  if (dtp->common.flags & IOPARM_DT_HAS_ID)
+	    *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);  
+	  else
+	    {
+	      enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE);
+	      /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+		 synchronous by performing a wait operation.  */
+	      if (!dtp->u.p.async)
+		async_wait (&dtp->common, dtp->u.p.current_unit->au);
+	    }
+	}
+      else
+	st_read_done_worker (dtp);
+
       unlock_unit (dtp->u.p.current_unit);
     }
 
@@ -4134,7 +4282,7 @@ void
 }
 
 extern void st_write (st_parameter_dt *);
-export_proto(st_write);
+export_proto (st_write);
 
 void
 st_write (st_parameter_dt *dtp)
@@ -4143,11 +4291,9 @@ st_write (st_parameter_dt *dtp)
   data_transfer_init (dtp, 0);
 }
 
-extern void st_write_done (st_parameter_dt *);
-export_proto(st_write_done);
 
 void
-st_write_done (st_parameter_dt *dtp)
+st_write_done_worker (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
 
@@ -4196,19 +4342,68 @@ void
 	  free_format_data (dtp->u.p.fmt);
 	  free_format (dtp);
 	}
+    }
+}
+
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+void
+st_write_done (st_parameter_dt *dtp)
+{
+  if (dtp->u.p.current_unit)
+    {
+      if (dtp->u.p.current_unit->au)
+	{
+	  if (dtp->common.flags & IOPARM_DT_HAS_ID)
+	    *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au,
+					AIO_WRITE_DONE);
+	  else
+	    {
+	      enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE);
+	      /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+		 synchronous by performing a wait operation.  */
+	      if (!dtp->u.p.async)
+		async_wait (&dtp->common, dtp->u.p.current_unit->au);
+	    }
+	}
+      else
+	st_write_done_worker (dtp);
+
       unlock_unit (dtp->u.p.current_unit);
     }
+
   library_end ();
 }
 
+/* Wait operation.  We need to keep around the do-nothing version
+ of st_wait for compatibility with previous versions, which had marked
+ the argument as unused (and thus liable to be removed).
 
-/* F2003: This is a stub for the runtime portion of the WAIT statement.  */
+ TODO: remove at next bump in version number.  */
+
 void
 st_wait (st_parameter_wait *wtp __attribute__((unused)))
 {
+  return;
 }
 
+void
+st_wait_async (st_parameter_wait *wtp)
+{
+  gfc_unit *u = find_unit (wtp->common.unit);
+  if (ASYNC_IO && u->au)
+    {
+      if (wtp->common.flags & IOPARM_WAIT_HAS_ID)
+	async_wait_id (&(wtp->common), u->au, *wtp->id);
+      else
+	async_wait (&(wtp->common), u->au);
+    }
 
+  unlock_unit (u);
+}
+
+
 /* Receives the scalar information for namelist objects and stores it
    in a linked list of namelist_info types.  */
 
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c	(revision 263244)
+++ libgfortran/io/unit.c	(working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include "fbuf.h"
 #include "format.h"
 #include "unix.h"
+#include "async.h"
 #include <string.h>
 #include <assert.h>
 
@@ -240,7 +241,7 @@ insert_unit (int n)
 #else
   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
 #endif
-  __gthread_mutex_lock (&u->lock);
+  LOCK (&u->lock);
   u->priority = pseudo_random ();
   unit_root = insert (u, unit_root);
   return u;
@@ -327,7 +328,9 @@ get_gfc_unit (int n, int do_create)
   gfc_unit *p;
   int c, created = 0;
 
-  __gthread_mutex_lock (&unit_lock);
+  NOTE ("Unit n=%d, do_create = %d", n, do_create);
+  LOCK (&unit_lock);
+
 retry:
   for (c = 0; c < CACHE_SIZE; c++)
     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
@@ -366,7 +369,7 @@ retry:
     {
       /* Newly created units have their lock held already
 	 from insert_unit.  Just unlock UNIT_LOCK and return.  */
-      __gthread_mutex_unlock (&unit_lock);
+      UNLOCK (&unit_lock);
       return p;
     }
 
@@ -374,10 +377,10 @@ found:
   if (p != NULL && (p->child_dtio == 0))
     {
       /* Fast path.  */
-      if (! __gthread_mutex_trylock (&p->lock))
+      if (! TRYLOCK (&p->lock))
 	{
 	  /* assert (p->closed == 0); */
-	  __gthread_mutex_unlock (&unit_lock);
+	  UNLOCK (&unit_lock);
 	  return p;
 	}
 
@@ -385,15 +388,15 @@ found:
     }
 
 
-  __gthread_mutex_unlock (&unit_lock);
+  UNLOCK (&unit_lock);
 
   if (p != NULL && (p->child_dtio == 0))
     {
-      __gthread_mutex_lock (&p->lock);
+      LOCK (&p->lock);
       if (p->closed)
 	{
-	  __gthread_mutex_lock (&unit_lock);
-	  __gthread_mutex_unlock (&p->lock);
+	  LOCK (&unit_lock);
+	  UNLOCK (&p->lock);
 	  if (predec_waiting_locked (p) == 0)
 	    destroy_unit_mutex (p);
 	  goto retry;
@@ -640,7 +643,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      __gthread_mutex_unlock (&u->lock);
+      UNLOCK (&u->lock);
     }
 
   if (options.stdout_unit >= 0)
@@ -671,7 +674,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      __gthread_mutex_unlock (&u->lock);
+      UNLOCK (&u->lock);
     }
 
   if (options.stderr_unit >= 0)
@@ -702,13 +705,13 @@ init_units (void)
       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
                               any kind of exotic formatting to stderr.  */
 
-      __gthread_mutex_unlock (&u->lock);
+      UNLOCK (&u->lock);
     }
   /* The default internal units.  */
   u = insert_unit (GFC_INTERNAL_UNIT);
-  __gthread_mutex_unlock (&u->lock);
+  UNLOCK (&u->lock);
   u = insert_unit (GFC_INTERNAL_UNIT4);
-  __gthread_mutex_unlock (&u->lock);
+  UNLOCK (&u->lock);
 }
 
 
@@ -717,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked)
 {
   int i, rc;
 
+  if (ASYNC_IO && u->au)
+    async_close (u->au);
+
   /* If there are previously written bytes from a write with ADVANCE="no"
      Reposition the buffer before closing.  */
   if (u->previous_nonadvancing_write)
@@ -726,7 +732,7 @@ close_unit_1 (gfc_unit *u, int locked)
 
   u->closed = 1;
   if (!locked)
-    __gthread_mutex_lock (&unit_lock);
+    LOCK (&unit_lock);
 
   for (i = 0; i < CACHE_SIZE; i++)
     if (unit_cache[i] == u)
@@ -744,7 +750,7 @@ close_unit_1 (gfc_unit *u, int locked)
     newunit_free (u->unit_number);
 
   if (!locked)
-    __gthread_mutex_unlock (&u->lock);
+    UNLOCK (&u->lock);
 
   /* If there are any threads waiting in find_unit for this unit,
      avoid freeing the memory, the last such thread will free it
@@ -753,7 +759,7 @@ close_unit_1 (gfc_unit *u, int locked)
     destroy_unit_mutex (u);
 
   if (!locked)
-    __gthread_mutex_unlock (&unit_lock);
+    UNLOCK (&unit_lock);
 
   return rc;
 }
@@ -761,7 +767,9 @@ close_unit_1 (gfc_unit *u, int locked)
 void
 unlock_unit (gfc_unit *u)
 {
-  __gthread_mutex_unlock (&u->lock);
+  NOTE ("unlock_unit = %d", u->unit_number);
+  UNLOCK (&u->lock);
+  NOTE ("unlock_unit done");
 }
 
 /* close_unit()-- Close a unit.  The stream is closed, and any memory
@@ -785,10 +793,10 @@ close_unit (gfc_unit *u)
 void
 close_units (void)
 {
-  __gthread_mutex_lock (&unit_lock);
+  LOCK (&unit_lock);
   while (unit_root != NULL)
     close_unit_1 (unit_root, 1);
-  __gthread_mutex_unlock (&unit_lock);
+  UNLOCK (&unit_lock);
 
   free (newunits);
 
@@ -895,7 +903,7 @@ finish_last_advance_record (gfc_unit *u)
 int
 newunit_alloc (void)
 {
-  __gthread_mutex_lock (&unit_lock);
+  LOCK (&unit_lock);
   if (!newunits)
     {
       newunits = xcalloc (16, 1);
@@ -909,7 +917,7 @@ newunit_alloc (void)
         {
           newunits[ii] = true;
           newunit_lwi = ii + 1;
-	  __gthread_mutex_unlock (&unit_lock);
+	  UNLOCK (&unit_lock);
           return -ii + NEWUNIT_START;
         }
     }
@@ -922,7 +930,7 @@ newunit_alloc (void)
   memset (newunits + old_size, 0, old_size);
   newunits[old_size] = true;
   newunit_lwi = old_size + 1;
-    __gthread_mutex_unlock (&unit_lock);
+    UNLOCK (&unit_lock);
   return -old_size + NEWUNIT_START;
 }
 
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c	(revision 263244)
+++ libgfortran/io/unix.c	(working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 
 #include "io.h"
 #include "unix.h"
+#include "async.h"
 #include <limits.h>
 
 #ifdef HAVE_UNISTD_H
@@ -1742,7 +1743,7 @@ find_file (const char *file, gfc_charlen_type file
   id = id_from_path (path);
 #endif
 
-  __gthread_mutex_lock (&unit_lock);
+  LOCK (&unit_lock);
 retry:
   u = find_file0 (unit_root, FIND_FILE0_ARGS);
   if (u != NULL)
@@ -1751,20 +1752,20 @@ retry:
       if (! __gthread_mutex_trylock (&u->lock))
 	{
 	  /* assert (u->closed == 0); */
-	  __gthread_mutex_unlock (&unit_lock);
+	  UNLOCK (&unit_lock);
 	  goto done;
 	}
 
       inc_waiting_locked (u);
     }
-  __gthread_mutex_unlock (&unit_lock);
+  UNLOCK (&unit_lock);
   if (u != NULL)
     {
-      __gthread_mutex_lock (&u->lock);
+      LOCK (&u->lock);
       if (u->closed)
 	{
-	  __gthread_mutex_lock (&unit_lock);
-	  __gthread_mutex_unlock (&u->lock);
+	  LOCK (&unit_lock);
+	  UNLOCK (&u->lock);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	  goto retry;
@@ -1794,7 +1795,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
 	    return u;
 	  if (u->s)
 	    sflush (u->s);
-	  __gthread_mutex_unlock (&u->lock);
+	  UNLOCK (&u->lock);
 	}
       u = u->right;
     }
@@ -1807,17 +1808,17 @@ flush_all_units (void)
   gfc_unit *u;
   int min_unit = 0;
 
-  __gthread_mutex_lock (&unit_lock);
+  LOCK (&unit_lock);
   do
     {
       u = flush_all_units_1 (unit_root, min_unit);
       if (u != NULL)
 	inc_waiting_locked (u);
-      __gthread_mutex_unlock (&unit_lock);
+      UNLOCK (&unit_lock);
       if (u == NULL)
 	return;
 
-      __gthread_mutex_lock (&u->lock);
+      LOCK (&u->lock);
 
       min_unit = u->unit_number + 1;
 
@@ -1824,14 +1825,14 @@ flush_all_units (void)
       if (u->closed == 0)
 	{
 	  sflush (u->s);
-	  __gthread_mutex_lock (&unit_lock);
-	  __gthread_mutex_unlock (&u->lock);
+	  LOCK (&unit_lock);
+	  UNLOCK (&u->lock);
 	  (void) predec_waiting_locked (u);
 	}
       else
 	{
-	  __gthread_mutex_lock (&unit_lock);
-	  __gthread_mutex_unlock (&u->lock);
+	  LOCK (&unit_lock);
+	  UNLOCK (&u->lock);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 263244)
+++ libgfortran/libgfortran.h	(working copy)
@@ -738,6 +738,9 @@ internal_proto(translate_error);
 extern void generate_error (st_parameter_common *, int, const char *);
 iexport_proto(generate_error);
 
+extern bool generate_error_common (st_parameter_common *, int, const char *);
+iexport_proto(generate_error_common);
+
 extern void generate_warning (st_parameter_common *, const char *);
 internal_proto(generate_warning);
 
@@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restric
 internal_proto(cshift1_16_c16);
 #endif
 
+/* Define this if we support asynchronous I/O on this platform.  This
+   currently requires weak symbols.  */
 
 #endif  /* LIBGFOR_H  */
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c	(revision 263244)
+++ libgfortran/runtime/error.c	(working copy)
@@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respect
 
 
 #include "libgfortran.h"
+#include "io.h"
+#include "async.h"
+
 #include <assert.h>
 #include <string.h>
 #include <errno.h>
@@ -526,24 +529,41 @@ translate_error (int code)
 }
 
 
-/* generate_error()-- Come here when an error happens.  This
- * subroutine is called if it is possible to continue on after the error.
- * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
- * ERR labels are present, we return, otherwise we terminate the program
- * after printing a message.  The error code is always required but the
- * message parameter can be NULL, in which case a string describing
- * the most recent operating system error is used. */
+/* Worker function for generate_error and generate_error_async.  Return true
+   if a straight return is to be done, zero if the program should abort. */
 
-void
-generate_error (st_parameter_common *cmp, int family, const char *message)
+bool
+generate_error_common (st_parameter_common *cmp, int family, const char *message)
 {
   char errmsg[STRERR_MAXSZ];
 
+#if ASYNC_IO
+  gfc_unit *u;
+
+  NOTE ("Entering generate_error_common");
+
+  u = thread_unit;
+  if (u && u->au)
+    {
+      if (u->au->error.has_error)
+	return true;
+
+      if (__gthread_equal (u->au->thread, __gthread_self ()))
+	{
+	  u->au->error.has_error = 1;
+	  u->au->error.cmp = cmp;
+	  u->au->error.family = family;
+	  u->au->error.message = message;
+	  return true;
+	}
+    }
+#endif
+
   /* If there was a previous error, don't mask it with another
      error message, EOF or EOR condition.  */
 
   if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
-    return;
+    return true;
 
   /* Set the error status.  */
   if ((cmp->flags & IOPARM_HAS_IOSTAT))
@@ -562,29 +582,30 @@ translate_error (int code)
   switch (family)
     {
     case LIBERROR_EOR:
-      cmp->flags |= IOPARM_LIBRETURN_EOR;
+      cmp->flags |= IOPARM_LIBRETURN_EOR;  NOTE("EOR");
       if ((cmp->flags & IOPARM_EOR))
-	return;
+	return true;
       break;
 
     case LIBERROR_END:
-      cmp->flags |= IOPARM_LIBRETURN_END;
+      cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
       if ((cmp->flags & IOPARM_END))
-	return;
+	return true;
       break;
 
     default:
-      cmp->flags |= IOPARM_LIBRETURN_ERROR;
+      cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
       if ((cmp->flags & IOPARM_ERR))
-	return;
+	return true;
       break;
     }
 
   /* Return if the user supplied an iostat variable.  */
   if ((cmp->flags & IOPARM_HAS_IOSTAT))
-    return;
+    return true;
 
-  /* Terminate the program */
+  /* Return code, caller is responsible for terminating
+   the program if necessary.  */
 
   recursion_check ();
   show_locus (cmp);
@@ -591,8 +612,27 @@ translate_error (int code)
   estr_write ("Fortran runtime error: ");
   estr_write (message);
   estr_write ("\n");
-  exit_error (2);
+  return false;
 }
+
+/* generate_error()-- Come here when an error happens.  This
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message.  The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used.
+ * If the error is for an asynchronous unit and if the program is currently
+ * executing the asynchronous thread, just mark the error and return.  */
+
+void
+generate_error (st_parameter_common *cmp, int family, const char *message)
+{
+  if (generate_error_common (cmp, family, message))
+    return;
+
+  exit_error(2);
+}
 iexport(generate_error);

Attachment: async_io_1.f90
Description: Text document

Attachment: async_io_2.f90
Description: Text document

Attachment: async_io_3.f90
Description: Text document

Attachment: async_io_4.f90
Description: Text document

Attachment: async_io_5.f90
Description: Text document

Attachment: async_io_6.f90
Description: Text document

Attachment: async_io_7.f90
Description: Text document