[fortran] Asynchronous I/O, take 3
diff mbox series

Message ID b373a033-8d47-9ede-6c08-03a2a3da588d@tkoenig.net
State New
Headers show
Series
  • [fortran] Asynchronous I/O, take 3
Related show

Commit Message

Thomas König July 2, 2018, 10:16 p.m. UTC
Hello world,

the attached patch is the third take on Nicolas' and my patch
for implementing asynchronous I/O.  Some parts have been reworked, and 
several bugs which caused either incorrect I/O or hangs have been
fixed in the process.

I have to say that getting out these bugs has been much harder
than Nicolas and I originally thought, and that this has cost more
working hours than any other patch I have been involved in.

This has been regression-tested on x86_64-pc-linux-gnu. The new test
cases have also been tested in a tight loop with

n=1; while ./a.out; do echo -n $n " " ; n=$((n+1)); done

or (for async_io_3.f90, which is supposed to fail)

while true ; do ./a.out > /dev/null 2>&1 ;  echo -n $n " " ; n=$((n+1)); 
done

and the test cases also come up clean with valgrind --tool=drd
(which is a _very_ strict tool which, after this experience, I
wholeheartedly recommend for doing pthreads debugging).

The interface remains as before - link in pthread to get asynchronous
I/O, which matches what ifort does.

So, OK for trunk?

Regards

	Thomas

2018-07-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-07-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-01-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-07-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
         Thomas Koenig <tkoenig@gcc.gnu.org>

         PR fortran/25829
         * testsuite/libgfomp.fortran/async_io_1.f90: New test.
         * testsuite/libgfomp.fortran/async_io_2.f90: New test.
         * testsuite/libgfomp.fortran/async_io_3.f90: New test.

Comments

Rainer Orth July 3, 2018, 2:24 p.m. UTC | #1
Hi Thomas,

> the attached patch is the third take on Nicolas' and my patch
> for implementing asynchronous I/O.  Some parts have been reworked, and
> several bugs which caused either incorrect I/O or hangs have been
> fixed in the process.
>
> I have to say that getting out these bugs has been much harder
> than Nicolas and I originally thought, and that this has cost more
> working hours than any other patch I have been involved in.
>
> This has been regression-tested on x86_64-pc-linux-gnu. The new test
> cases have also been tested in a tight loop with
>
> n=1; while ./a.out; do echo -n $n " " ; n=$((n+1)); done
>
> or (for async_io_3.f90, which is supposed to fail)
>
> while true ; do ./a.out > /dev/null 2>&1 ;  echo -n $n " " ; n=$((n+1));
> done
>
> and the test cases also come up clean with valgrind --tool=drd
> (which is a _very_ strict tool which, after this experience, I
> wholeheartedly recommend for doing pthreads debugging).
>
> The interface remains as before - link in pthread to get asynchronous
> I/O, which matches what ifort does.

another test run on i386-pc-solaris2.11 is underway.  However, may
(all?) gfortran tests now SEGV.  One example is

Program received signal SIGSEGV: Segmentation fault - invalid memory reference.

Backtrace for this error:
Segmentation Fault

Thread 2 received signal SIGSEGV, Segmentation fault.
[Switching to Thread 1 (LWP 1)]
0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
(gdb) where
#0  0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
#1  0xfe5d1b7c in __gthread_mutex_unlock (__mutex=0x18)
    at ../libgcc/gthr-default.h:778
#2  _gfortran_st_rewind (fpp=0xfeffda9c)
    at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:486
#3  0x0805110f in MAIN__ ()
    at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/backslash_2.f90:6  

Obviously __mutex above hasn't been properly initialized.

> 2018-07-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
>         Thomas Koenig <tkoenig@gcc.gnu.org>
>
>         PR fortran/25829
>         * testsuite/libgfomp.fortran/async_io_1.f90: New test.
>         * testsuite/libgfomp.fortran/async_io_2.f90: New test.
>         * testsuite/libgfomp.fortran/async_io_3.f90: New test.

You seem to have a special fondness for libgfomp ;-)

	Rainer
Rainer Orth July 3, 2018, 2:42 p.m. UTC | #2
Hi Thomas,

> another test run on i386-pc-solaris2.11 is underway.  However, may
> (all?) gfortran tests now SEGV.  One example is

the good news is: all three libgomp.fortran/async_io_?.f90 tests now
PASS for both 32 and 64-bit, as do gfortran.dg/f2003_inquire_1.f03 and
gfortran.dg/f2003_io_1.f03.

	Rainer
Thomas König July 3, 2018, 5:45 p.m. UTC | #3
Hi Rainer,

> However, may
> (all?) gfortran tests now SEGV.  One example is
> 
> Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
> 
> Backtrace for this error:
> Segmentation Fault
> 
> Thread 2 received signal SIGSEGV, Segmentation fault.
> [Switching to Thread 1 (LWP 1)]
> 0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
> (gdb) where
> #0  0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
> #1  0xfe5d1b7c in __gthread_mutex_unlock (__mutex=0x18)
>      at ../libgcc/gthr-default.h:778
> #2  _gfortran_st_rewind (fpp=0xfeffda9c)
>      at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:486
> #3  0x0805110f in MAIN__ ()
>      at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/backslash_2.f90:6

Ah, I see what was wrong.

The attached patch should fix this.

I have also attached a new test case which detects this error
even on Linux systems, plus a ChangeLog which fixes the typo :-)

Again regression-tested.

So, OK for trunk?

Regards

	Thomas

2018-07-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-07-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-01-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-07-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.


> Obviously __mutex above hasn't been properly initialized.
> 
>> 2018-07-02  Nicolas Koenig  <koenigni@gcc.gnu.org>
>>          Thomas Koenig <tkoenig@gcc.gnu.org>
>>
>>          PR fortran/25829
>>          * testsuite/libgfomp.fortran/async_io_1.f90: New test.
>>          * testsuite/libgfomp.fortran/async_io_2.f90: New test.
>>          * testsuite/libgfomp.fortran/async_io_3.f90: New test.
> 
> You seem to have a special fondness for libgfomp ;-)
> 
> 	Rainer
>
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi	(Revision 259739)
+++ gcc/fortran/gfortran.texi	(Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
 
 
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ gcc/fortran/trans-io.c	(Arbeitskopie)
@@ -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 259739)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03	(Arbeitskopie)
@@ -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 259739)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/Makefile.am	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/Makefile.in	(Arbeitskopie)
@@ -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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map	(Arbeitskopie)
@@ -1482,3 +1482,8 @@ GFORTRAN_C99_8 {
     y1f;
     ynf;
 };
+
+GFORTRAN_9 {
+  global:
+  _gfortran_st_wait_async;
+};
Index: libgfortran/io/async.c
===================================================================
--- libgfortran/io/async.c	(nicht existent)
+++ libgfortran/io/async.c	(Arbeitskopie)
@@ -0,0 +1,483 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+   Contributed by Nicolas Koenig
+
+   This file is part of the GNU Fortran runtime library (libgfortran).
+
+   Libgfortran is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3, or (at your option)
+   any later version.
+
+   Libgfortran is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   Under Section 7 of GPL version 3, you are granted additional
+   permissions described in the GCC Runtime Library Exception, version
+   3.1, as published by the Free Software Foundation.
+
+   You should have received a copy of the GNU General Public License and
+   a copy of the GCC Runtime Library Exception along with this program;
+   see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <assert.h>
+
+#include <sys/types.h>
+
+#include "async.h"
+
+DEBUG_LINE (__thread const char *aio_prefix = MPREFIX);
+
+DEBUG_LINE (__gthread_mutex_t debug_queue_lock = __GTHREAD_MUTEX_INIT;)
+DEBUG_LINE (aio_lock_debug *aio_debug_head = NULL;)
+
+/* Current unit for asynchronous I/O.  Needed for error reporting.  */
+
+__thread gfc_unit *thread_unit = NULL;
+
+/* Queue entry for the asynchronous I/O entry.  */
+typedef struct transfer_queue
+{
+  enum aio_do type;
+  struct transfer_queue *next;
+  struct st_parameter_dt *new_pdt;
+  transfer_args arg;
+  _Bool has_id;
+  int read_flag;
+} transfer_queue;
+
+struct error {
+  st_parameter_dt *dtp;
+  int id;
+};
+
+/* Helper function to exchange the old vs. a new PDT.  */
+
+static void
+update_pdt (st_parameter_dt **old, st_parameter_dt *new) {
+  st_parameter_dt *temp;
+  NOTE ("Changing pdts, current_unit = %p", (void *) (new->u.p.current_unit));
+  temp = *old;
+  *old = new;
+  if (temp)
+    free (temp);
+}
+
+/* Destroy an adv_cond structure.  */
+
+static void
+destroy_adv_cond (struct adv_cond *ac)
+{
+  T_ERROR (__gthread_mutex_destroy, &ac->lock);
+  T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+/* Function invoked as start routine for a new asynchronous I/O unit.
+   Contains the main loop for accepting requests and handling them.  */
+
+static void *
+async_io (void *arg)
+{
+  DEBUG_LINE (aio_prefix = TPREFIX);
+  transfer_queue *ctq = NULL, *prev = NULL;
+  gfc_unit *u = (gfc_unit *) arg;
+  async_unit *au = u->au;
+  LOCK (&au->lock);
+  thread_unit = u;
+  au->thread = __gthread_self ();
+  while (true)
+    {
+      /* Main loop.  At this point, au->lock is always held. */
+      WAIT_SIGNAL_MUTEX (&au->work, au->tail != NULL, &au->lock);
+      LOCK (&au->lock);
+      ctq = au->head;
+      prev = NULL;
+      /* Loop over the queue entries until they are finished.  */
+      while (ctq)
+	{
+	  if (prev)
+	    free (prev);
+	  prev = ctq;
+	  if (!au->error.has_error)
+	    {
+	      UNLOCK (&au->lock);
+
+	      switch (ctq->type)
+		{
+		case AIO_WRITE_DONE:
+		  NOTE ("Finalizing write");
+		  st_write_done_worker (au->pdt);
+		  UNLOCK (&au->io_lock);
+		  break;
+
+		case AIO_READ_DONE:
+		  NOTE ("Finalizing read");
+		  st_read_done_worker (au->pdt);
+		  UNLOCK (&au->io_lock);
+		  break;
+
+		case AIO_DATA_TRANSFER_INIT:
+		  NOTE ("Data transfer init");
+		  LOCK (&au->io_lock);
+		  update_pdt (&au->pdt, ctq->new_pdt);
+		  data_transfer_init_worker (au->pdt, ctq->read_flag);
+		  break;
+
+		case AIO_TRANSFER_SCALAR:
+		  NOTE ("Starting scalar transfer");
+		  ctq->arg.scalar.transfer (au->pdt, ctq->arg.scalar.arg_bt,
+					    ctq->arg.scalar.data,
+					    ctq->arg.scalar.i,
+					    ctq->arg.scalar.s1,
+					    ctq->arg.scalar.s2);
+		  break;
+
+		case AIO_TRANSFER_ARRAY:
+		  NOTE ("Starting array transfer");
+		  NOTE ("ctq->arg.array.desc = %p",
+			(void *) (ctq->arg.array.desc));
+		  transfer_array_inner (au->pdt, ctq->arg.array.desc,
+					ctq->arg.array.kind,
+					ctq->arg.array.charlen);
+		  free (ctq->arg.array.desc);
+		  break;
+
+		case AIO_CLOSE:
+		  NOTE ("Received AIO_CLOSE");
+		  goto finish_thread;
+
+		default:
+		  internal_error (NULL, "Invalid queue type");
+		  break;
+		}
+	      LOCK (&au->lock);
+	      if (unlikely (au->error.has_error))
+		au->error.last_good_id = au->id.low - 1;
+	    }
+	  else
+	    {
+	      if (ctq->type == AIO_WRITE_DONE || ctq->type == AIO_READ_DONE)
+		{
+		  UNLOCK (&au->io_lock);
+		}
+	      else if (ctq->type == AIO_CLOSE)
+		{
+		  NOTE ("Received AIO_CLOSE during error condition");
+		  UNLOCK (&au->lock);
+		  goto finish_thread;
+		}
+	    }
+
+  	  NOTE ("Next ctq, current id: %d", au->id.low);
+  	  if (ctq->has_id && au->id.waiting == au->id.low++)
+	    SIGNAL (&au->id.done);
+
+	  ctq = ctq->next;
+	}
+      au->tail = NULL;
+      au->head = NULL;
+      au->empty = 1;
+      UNLOCK (&au->lock);
+      SIGNAL (&au->emptysignal);
+      LOCK (&au->lock);
+    }
+ finish_thread:
+  au->tail = NULL;
+  au->head = NULL;
+  au->empty = 1;
+  SIGNAL (&au->emptysignal);
+  free (ctq);
+  return NULL;
+}
+
+/* Free an asynchronous unit.  */
+
+static void
+free_async_unit (async_unit *au)
+{
+  if (au->tail)
+    internal_error (NULL, "Trying to free nonempty asynchronous unit");
+
+  destroy_adv_cond (&au->work);
+  destroy_adv_cond (&au->emptysignal);
+  destroy_adv_cond (&au->id.done);
+  T_ERROR (__gthread_mutex_destroy, &au->lock);
+  free (au);
+}
+
+/* Initialize an adv_cond structure.  */
+
+static void
+init_adv_cond (struct adv_cond *ac)
+{
+  ac->pending = 0;
+  __GTHREAD_MUTEX_INIT_FUNCTION (&ac->lock);
+  __gthread_cond_init_function (&ac->signal);
+}
+
+/* Initialize an asyncronous unit, returning zero on success,
+ nonzero on failure.  It also sets u->au.  */
+
+void
+init_async_unit (gfc_unit *u)
+{
+  async_unit *au;
+  if (!__gthread_active_p ())
+    {
+      u->au = NULL;
+      return;
+    }
+  
+  au = (async_unit *) xmalloc (sizeof (async_unit));
+  u->au = au;
+  init_adv_cond (&au->work);
+  init_adv_cond (&au->emptysignal);
+  __GTHREAD_MUTEX_INIT_FUNCTION (&au->lock);
+  __GTHREAD_MUTEX_INIT_FUNCTION (&au->io_lock);
+  LOCK (&au->lock);
+  T_ERROR (__gthread_create, &au->thread, &async_io, (void *) u);
+  au->pdt = NULL;
+  au->head = NULL;
+  au->tail = NULL;
+  au->empty = true;
+  au->id.waiting = -1;
+  au->id.low = 0;
+  au->id.high = 0;
+  au->error.fatal_error = 0;
+  au->error.has_error = 0;
+  au->error.last_good_id = 0;
+  init_adv_cond (&au->id.done);
+  UNLOCK (&au->lock);
+}
+
+/* Enqueue a transfer statement.  */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+  tq->arg = *arg;
+  tq->type = type;
+  tq->has_id = 0;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Enqueue an st_write_done or st_read_done which contains an ID.  */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+  int ret;
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+  tq->type = type;
+  tq->has_id = 1;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  ret = au->id.high++;
+  NOTE ("Enqueue id: %d", ret);
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+  return ret;
+}
+
+/* Enqueue an st_write_done or st_read_done without an ID.  */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+  tq->type = type;
+  tq->has_id = 0;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Enqueue a CLOSE statement.  */
+
+void
+enqueue_close (async_unit *au)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+  tq->type = AIO_CLOSE;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* The asynchronous unit keeps the currently active PDT around.
+   This function changes that to the current one.  */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+  st_parameter_dt *new = xmalloc (sizeof (st_parameter_dt));
+  transfer_queue *tq = xmalloc (sizeof (transfer_queue));
+
+  memcpy ((void *) new, (void *) dt, sizeof (st_parameter_dt));
+
+  NOTE ("dt->internal_unit_desc = %p", dt->internal_unit_desc);
+  NOTE ("common.flags & mask = %d", dt->common.flags & IOPARM_LIBRETURN_MASK);
+  tq->next = NULL;
+  tq->type = AIO_DATA_TRANSFER_INIT;
+  tq->read_flag = read_flag;
+  tq->has_id = 0;
+  tq->new_pdt = new;
+  LOCK (&au->lock);
+
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = 0;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Collect the errors that may have happened asynchronously.  Return true if
+   an error has been encountered.  */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+  bool has_error = au->error.has_error;
+
+  if (has_error)
+    {
+      if (generate_error_common (cmp, au->error.family, au->error.message))
+	{
+	  au->error.has_error = 0;
+	  au->error.cmp = NULL;
+	}
+      else
+	{
+	  /* The program will exit later.  */
+	  au->error.fatal_error = true;
+	}
+    }
+  return has_error;
+}
+
+/* Perform a wait operation on an asynchronous unit with an ID specified,
+   which means collecting the errors that may have happened asynchronously.
+   Return true if an error has been encountered.  */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+  bool ret;
+
+  if (au == NULL)
+    return false;
+
+  if (cmp == NULL)
+    cmp = au->error.cmp;
+
+  if (au->error.has_error)
+    {
+      if (i <= au->error.last_good_id)
+	return false;
+
+      return collect_async_errors (cmp, au);
+    }
+
+  LOCK (&au->lock);
+  NOTE ("Waiting for id %d", i);
+  if (au->id.waiting < i)
+    au->id.waiting = i;
+  UNLOCK (&au->lock);
+  SIGNAL (&(au->work));
+  LOCK (&au->lock);
+  WAIT_SIGNAL_MUTEX (&(au->id.done),
+		     (au->id.low >= au->id.waiting || au->empty), &au->lock);
+  LOCK (&au->lock);
+  ret = collect_async_errors (cmp, au);
+  UNLOCK (&au->lock);
+  return ret;
+}
+
+/* Perform a wait operation an an asynchronous unit without an ID.  */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+  bool ret;
+
+  if (au == NULL)
+    return false;
+
+  if (cmp == NULL)
+    cmp = au->error.cmp;
+
+  SIGNAL (&(au->work));
+  LOCK (&(au->lock));
+
+  if (au->empty)
+    {
+      ret = collect_async_errors (cmp, au);
+      UNLOCK (&au->lock);
+      return ret;
+    }
+
+  WAIT_SIGNAL_MUTEX (&(au->emptysignal), (au->empty), &au->lock);
+  ret = collect_async_errors (cmp, au);
+  return ret;
+}
+
+/* Close an asynchronous unit.  */
+
+void
+async_close (async_unit *au)
+{
+  if (au == NULL)
+    return;
+
+  NOTE ("Closing async unit");
+  enqueue_close (au);
+  T_ERROR (__gthread_join, au->thread, NULL);
+  free_async_unit (au);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h	(nicht existent)
+++ libgfortran/io/async.h	(Arbeitskopie)
@@ -0,0 +1,378 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+   Contributed by Nicolas Koenig
+
+   This file is part of the GNU Fortran runtime library (libgfortran).
+
+   Libgfortran is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3, or (at your option)
+   any later version.
+
+   Libgfortran is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   Under Section 7 of GPL version 3, you are granted additional
+   permissions described in the GCC Runtime Library Exception, version
+   3.1, as published by the Free Software Foundation.
+
+   You should have received a copy of the GNU General Public License and
+   a copy of the GCC Runtime Library Exception along with this program;
+   see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#ifndef ASYNC_H
+#define ASYNC_H
+
+/* Defining DEBUG_ASYNC will enable somewhat verbose debugging
+   output for async I/O.  */
+
+#define DEBUG_ASYNC
+#undef DEBUG_ASYNC
+
+#ifdef DEBUG_ASYNC
+
+/* Define this if you want to use ANSI color escape sequences in your
+   debugging output.  */
+
+#define DEBUG_COLOR
+
+#ifdef DEBUG_COLOR
+#define MPREFIX "\033[30;46mM:\033[0m "
+#define TPREFIX "\033[37;44mT:\033[0m "
+#define RPREFIX "\033[37;41mR:\033[0m "
+#define DEBUG_RED "\033[31m"
+#define DEBUG_ORANGE "\033[33m"
+#define DEBUG_GREEN "\033[32m"
+#define DEBUG_DARKRED "\033[31;2m"
+#define DEBUG_PURPLE "\033[35m"
+#define DEBUG_NORM "\033[0m"
+#define DEBUG_REVERSE_RED "\033[41;37m"
+#define DEBUG_BLUE "\033[34m"
+
+#else
+
+#define MPREFIX "M: "
+#define TPREFIX "T: "
+#define RPREFIX ""
+#define DEBUG_RED ""
+#define DEBUG_ORANGE ""
+#define DEBUG_GREEN ""
+#define DEBUG_DARKRED ""
+#define DEBUG_PURPLE ""
+#define DEBUG_NORM ""
+#define DEBUG_REVERSE_RED ""
+#define DEBUG_BLUE ""
+
+#endif
+
+#define DEBUG_PRINTF(...) fprintf (stderr,__VA_ARGS__)
+
+#define IN_DEBUG_QUEUE(mutex) ({		\
+      __label__ end;				\
+      aio_lock_debug *curr = aio_debug_head;	\
+      while (curr) {				\
+	if (curr->m == mutex) {			\
+	  goto end;				\
+	}					\
+	curr = curr->next;			\
+      }						\
+    end:;					\
+      curr;					\
+    })
+
+#define TAIL_DEBUG_QUEUE ({			\
+      aio_lock_debug *curr = aio_debug_head;	\
+      while (curr && curr->next) {		\
+	curr = curr->next;			\
+      }						\
+      curr;					\
+    })
+
+#define CHECK_LOCK(mutex, status) do {					\
+    aio_lock_debug *curr;						\
+    INTERN_LOCK (&debug_queue_lock);					\
+    if (__gthread_mutex_trylock (mutex)) {				\
+      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 {								\
+      __gthread_mutex_unlock (mutex);					\
+      sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM);			\
+    }									\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+  }while (0)
+
+#define T_ERROR(func, ...) do {				\
+    int t_error_temp;					\
+    t_error_temp = func(__VA_ARGS__);			\
+    if (t_error_temp)					\
+      ERROR (t_error_temp, "args: " #__VA_ARGS__ "\n");	\
+  } while (0)
+
+#define NOTE(str, ...) do{						\
+    char note_str[200];							\
+    sprintf (note_str, "%s" DEBUG_PURPLE "NOTE: " DEBUG_NORM str, aio_prefix, ##__VA_ARGS__); \
+    DEBUG_PRINTF ("%-90s %20s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+  }while (0);
+
+#define ERROR(errnum, str, ...) do{					\
+    char note_str[200];							\
+    sprintf (note_str, "%s" DEBUG_REVERSE_RED "ERROR:" DEBUG_NORM " [%d] " str, aio_prefix, \
+	    errnum, ##__VA_ARGS__);					\
+    DEBUG_PRINTF ("%-68s %s():%-5d\n", note_str, __FUNCTION__, __LINE__);	\
+  }while (0)
+
+#define MUTEX_DEBUG_ADD(mutex) do {		\
+    aio_lock_debug *n;				\
+    n = malloc (sizeof(aio_lock_debug));	\
+    n->prev = TAIL_DEBUG_QUEUE;			\
+    if (n->prev)				\
+      n->prev->next = n;			\
+    n->next = NULL;				\
+    n->line = __LINE__;				\
+    n->func = __FUNCTION__;			\
+    n->m = mutex;				\
+    if (!aio_debug_head) {			\
+      aio_debug_head = n;			\
+    }						\
+  } while (0)
+
+#define UNLOCK(mutex) do {						\
+    aio_lock_debug *curr;						\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_GREEN "UNLOCK: " DEBUG_NORM #mutex, \
+		 __FUNCTION__, __LINE__, (void *) mutex);		\
+    INTERN_LOCK (&debug_queue_lock);					\
+    curr = IN_DEBUG_QUEUE (mutex);					\
+    if (curr)								\
+      {									\
+	if (curr->prev)							\
+	  curr->prev->next = curr->next;				\
+	if (curr->next) {						\
+	  curr->next->prev = curr->prev;				\
+	  if (curr == aio_debug_head)					\
+	    aio_debug_head = curr->next;				\
+	} else {							\
+	  if (curr == aio_debug_head)					\
+	    aio_debug_head = NULL;					\
+	}								\
+	free (curr);							\
+      }									\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+    INTERN_UNLOCK (mutex);						\
+  }while (0)
+
+#define TRYLOCK(mutex) ({						\
+			 char status[200];				\
+			 int res;					\
+			 aio_lock_debug *curr;				\
+			 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 #mutex, status, __FUNCTION__, __LINE__, \
+				      (void *) mutex);			\
+			 INTERN_UNLOCK (&debug_queue_lock);		\
+			 res;						\
+    })
+
+#define LOCK(mutex) do {						\
+    char status[200];							\
+    CHECK_LOCK (mutex, status);						\
+    DEBUG_PRINTF ("%s%-42s prev: %-35s %20s():%-5d %18p\n", aio_prefix,	\
+		 DEBUG_RED "LOCK: " DEBUG_NORM #mutex, status, __FUNCTION__, __LINE__, (void *) mutex); \
+    INTERN_LOCK (mutex);							\
+    INTERN_LOCK (&debug_queue_lock);					\
+    MUTEX_DEBUG_ADD (mutex);						\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+    DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
+  } while (0)
+
+#define DEBUG_LINE(...) __VA_ARGS__
+
+#else
+#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)
+#define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+#define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+#endif
+
+#define INTERN_LOCK(mutex) T_ERROR (__gthread_mutex_lock, mutex);
+
+#define INTERN_UNLOCK(mutex) T_ERROR (__gthread_mutex_unlock, mutex);
+
+#define SIGNAL(advcond) do{						\
+    INTERN_LOCK (&(advcond)->lock);					\
+    (advcond)->pending = 1;						\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "SIGNAL: " DEBUG_NORM \
+		 #advcond, __FUNCTION__, __LINE__, (void *) advcond);	\
+    T_ERROR (__gthread_cond_broadcast, &(advcond)->signal);		\
+    INTERN_UNLOCK (&(advcond)->lock);					\
+  } while (0)
+
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{		\
+    __label__ finish;		       					\
+    INTERN_LOCK (&((advcond)->lock));					\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_BLUE "WAITING: " DEBUG_NORM \
+		 #advcond, __FUNCTION__, __LINE__, (void *) advcond);	\
+    if ((advcond)->pending || (condition)){				\
+      UNLOCK (mutex);							\
+      goto finish;							\
+    }									\
+    UNLOCK (mutex);							\
+     while (!__gthread_cond_wait(&(advcond)->signal, &(advcond)->lock)) {	\
+       { int cond;							\
+	 LOCK (mutex); cond = condition; UNLOCK (mutex);	\
+	   if (cond){							\
+	     DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "REC: " DEBUG_NORM \
+		  #advcond,  __FUNCTION__, __LINE__, (void *)advcond);	\
+	   break;				      			\
+        }							\
+      }									\
+    }									\
+  finish:								\
+		 (advcond)->pending = 0;				\
+		 INTERN_UNLOCK (&((advcond)->lock));			\
+		 } while (0)
+
+#define REVOKE_SIGNAL(advcond) do{		\
+    INTERN_LOCK (&(advcond)->lock);		\
+    (advcond)->pending = 0;			\
+    INTERN_UNLOCK (&(advcond)->lock);		\
+  } while (0)
+
+DEBUG_LINE (extern __thread const char *aio_prefix);
+
+DEBUG_LINE (typedef struct aio_lock_debug{
+  __gthread_mutex_t *m;
+  int line;
+  const char *func;
+  struct aio_lock_debug *next;
+  struct aio_lock_debug *prev;
+} aio_lock_debug;)
+
+DEBUG_LINE (extern aio_lock_debug *aio_debug_head;)
+DEBUG_LINE (extern __gthread_mutex_t debug_queue_lock;)
+
+/* Thread - local storage of the current unit we are looking at. Needed for
+   error reporting.  */
+
+extern __thread gfc_unit *thread_unit;
+
+enum aio_do {
+  AIO_INVALID = 0,
+  AIO_DATA_TRANSFER_INIT,
+  AIO_TRANSFER_SCALAR,
+  AIO_TRANSFER_ARRAY,
+  AIO_WRITE_DONE,
+  AIO_READ_DONE,
+  AIO_CLOSE
+};
+
+typedef union transfer_args
+{
+  struct
+  {
+    void (*transfer) (struct st_parameter_dt *, bt, void *, int, size_t, size_t);
+    bt arg_bt;
+    void *data;
+    int i;
+    size_t s1;
+    size_t s2;
+  } scalar;
+  struct
+  {
+    gfc_array_char *desc;
+    int kind;
+    gfc_charlen_type charlen;
+  } array;
+} transfer_args;
+
+struct adv_cond
+{
+  int pending;
+  __gthread_mutex_t lock;
+  __gthread_cond_t signal;
+};
+
+typedef struct async_unit
+{
+  pthread_mutex_t lock;      /* Lock for manipulating the queue structure.  */
+  pthread_mutex_t io_lock;   /* Lock for doing actual I/O. */
+  struct adv_cond work;
+  struct adv_cond emptysignal;
+  struct st_parameter_dt *pdt;
+  pthread_t thread;
+  struct transfer_queue *head;
+  struct transfer_queue *tail;
+  struct
+  {
+    int waiting;
+    int low;
+    int high;
+    struct adv_cond done;
+  } id;
+
+  bool empty;
+
+  struct {
+    const char *message;
+    st_parameter_common *cmp;
+    bool has_error;
+    int last_good_id;
+    int family;
+    bool fatal_error;
+  } error;
+
+} async_unit;
+
+void init_async_unit (gfc_unit *);
+internal_proto (init_async_unit);
+
+bool async_wait (st_parameter_common *, async_unit *);
+internal_proto (async_wait);
+
+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); 
+
+void async_close (async_unit *);
+internal_proto (async_close);
+
+void enqueue_transfer (async_unit * au, transfer_args * arg, enum aio_do);
+internal_proto (enqueue_transfer);
+
+void enqueue_done (async_unit *, enum aio_do type);
+internal_proto (enqueue_done);
+
+int enqueue_done_id (async_unit *, enum aio_do type);
+internal_proto (enqueue_done_id);
+
+void enqueue_init (async_unit *);
+internal_proto (enqueue_init);
+
+void enqueue_data_transfer_init (async_unit *, st_parameter_dt *, int);
+internal_proto (enqueue_data_transfer_init);
+
+void enqueue_close (async_unit *);
+internal_proto (enqueue_close);
+
+#endif
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c	(Revision 259739)
+++ libgfortran/io/close.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/file_pos.c	(Arbeitskopie)
@@ -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 (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 (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 (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 (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 (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 (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,14 @@ st_flush (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
+      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 +527,8 @@ st_flush (st_parameter_filepos *fpp)
     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
 			"Specified UNIT in FLUSH is not connected");
 
+  if (u->au && needs_unlock)
+    UNLOCK (&u->au->io_lock);
+
   library_end ();
 }
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c	(Revision 259739)
+++ libgfortran/io/inquire.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/io.h	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/open.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/read.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/transfer.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/unit.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/unix.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/libgfortran.h	(Arbeitskopie)
@@ -743,6 +743,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);
 
@@ -1748,5 +1751,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 259739)
+++ libgfortran/runtime/error.c	(Arbeitskopie)
@@ -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,38 @@ 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];
+  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;
+	}
+    }
+
   /* 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 +579,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 +609,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);
! { dg-do run }
! Check basic functionality of async I/O
program main
  implicit none
  integer:: i=1, j=2, k, l
  real :: a, b, c, d
  character(3), parameter:: yes="yes"
  character(4) :: str
  complex :: cc, dd
  integer, dimension(4):: is = [0, 1, 2, 3]
  integer, dimension(4):: res
  character(10) :: inq

  open (10, file='a.dat', asynchronous=yes)
  cc = (1.5, 0.5)
  inquire (10,asynchronous=inq)
  if (inq /= "YES") stop 1
  write (10,*,asynchronous=yes) 4, 3
  write (10,*,asynchronous=yes) 2, 1
  write (10,*,asynchronous=yes) 1.0, 3.0
  write (10,'(A)', asynchronous=yes) 'asdf'
  write (10,*, asynchronous=yes) cc
  close (10)
  stop
  open (20, file='a.dat', asynchronous=yes)
  read (20, *, asynchronous=yes) i, j
  read (20, *, asynchronous=yes) k, l
  read (20, *, asynchronous=yes) a, b
  read (20,'(A4)',asynchronous=yes) str
  read (20,*, asynchronous=yes) dd
  wait (20)
  if (i /= 4 .or. j /= 3) stop 2
  if (k /= 2 .or. l /= 1) stop 3
  if (a /= 1.0 .or. b /= 3.0) stop 4
  if (str /= 'asdf') stop 5
  if (cc /= dd) stop 6
  close (20,status="delete")

  open(10, file='c.dat', asynchronous=yes) 
  write(10, *, asynchronous=yes) is
  close(10)
  open(20, file='c.dat', asynchronous=yes) 
  read(20, *, asynchronous=yes) res
  wait (20)
  if (any(res /= is)) stop 1
  close (20,status="delete")
end program
! { dg-do  run }
program main
  implicit none
  integer :: i, ios
  character(len=100) :: iom
  open (10,file="tst.dat")
  write (10,'(A4)') 'asdf'
  close(10)
  i = 234
  open(10,file="tst.dat", asynchronous="yes")
  read (10,'(I4)',asynchronous="yes") i
  iom = ' '
  wait (10,iostat=ios,iomsg=iom)
  if (iom == ' ') stop 1
  close(10,status="delete")
end program main
! { dg-do run }
program main
  integer :: i
  open (10,file="tst.dat")
  write (10,'(A4)') 'asdf'
  close(10)
  i = 234
  open(10,file="tst.dat", asynchronous="yes")
  read (10,'(I4)',asynchronous="yes") i
  wait(10)
end program main
! { dg-output "Fortran runtime error: Bad value during integer read" }
! { dg-final { remote_file build delete "tst.dat" } }
! { dg-do run { target fd_truncate } }

! Test BACKSPACE for synchronous and asynchronous I/O
program main
  
  integer i, n, nr
  real x(10), y(10)

  ! PR libfortran/20068
  open (20, status='scratch', asynchronous="yes")
  write (20,*, asynchronous="yes" ) 1
  write (20,*, asynchronous="yes") 2
  write (20,*, asynchronous="yes") 3
  rewind (20)
  i = 41
  read (20,*, asynchronous="yes") i
  wait (20)
  if (i .ne. 1) STOP 1
  write (*,*) ' '
  backspace (20)
  i = 42
  read (20,*, asynchronous="yes") i
  close (20)
  if (i .ne. 1) STOP 2

  ! PR libfortran/20125
  open (20, status='scratch', asynchronous="yes")
  write (20,*, asynchronous="yes") 7
  backspace (20)
  read (20,*, asynchronous="yes") i
  wait (20)
  if (i .ne. 7) STOP 3
  close (20)

  open (20, status='scratch', form='unformatted')
  write (20) 8
  backspace (20)
  read (20) i
  if (i .ne. 8) STOP 4
  close (20)

  ! PR libfortran/20471
  do n = 1, 10
     x(n) = sqrt(real(n))
  end do
  open (3, form='unformatted', status='scratch')
  write (3) (x(n),n=1,10)
  backspace (3)
  rewind (3)
  read (3) (y(n),n=1,10)

  do n = 1, 10
     if (abs(x(n)-y(n)) > 0.00001) STOP 5
  end do
  close (3)

  ! PR libfortran/20156
  open (3, form='unformatted', status='scratch')
  do i = 1, 5
     x(1) = i
     write (3) n, (x(n),n=1,10)
  end do
  nr = 0
  rewind (3)
20 continue
  read (3,end=30,err=90) n, (x(n),n=1,10)
  nr = nr + 1
  goto 20
30 continue
  if (nr .ne. 5) STOP 6

  do i = 1, nr+1
     backspace (3)
  end do

  do i = 1, nr
     read(3,end=70,err=90) n, (x(n),n=1,10)
     if (abs(x(1) - i) .gt. 0.001) STOP 7
  end do
  close (3)
  stop

70 continue
  STOP 8
90 continue
  STOP 9

end program
Rainer Orth July 4, 2018, 8:04 a.m. UTC | #4
Hi Thomas,

> Ah, I see what was wrong.
>
> The attached patch should fix this.

it almost did the trick indeed.  With the new patch, only two failures
remain:

FAIL: gfortran.dg/flush_1.f90   -O0  execution test
FAIL: gfortran.dg/flush_1.f90   -O1  execution test
FAIL: gfortran.dg/flush_1.f90   -O2  execution test
FAIL: gfortran.dg/flush_1.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
FAIL: gfortran.dg/flush_1.f90   -O3 -g  execution test
FAIL: gfortran.dg/flush_1.f90   -Os  execution test
FAIL: gfortran.dg/newunit_1.f90   -O0  execution test
FAIL: gfortran.dg/newunit_1.f90   -O1  execution test
FAIL: gfortran.dg/newunit_1.f90   -O2  execution test
FAIL: gfortran.dg/newunit_1.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
FAIL: gfortran.dg/newunit_1.f90   -O3 -g  execution test
FAIL: gfortran.dg/newunit_1.f90   -Os  execution test

Program received signal SIGSEGV: Segmentation fault - invalid memory reference.

Backtrace for this error:
Segmentation Fault

Thread 2 received signal SIGSEGV, Segmentation fault.
[Switching to Thread 1 (LWP 1)]
0xfe1b1773 in mutex_lock_impl () from /lib/libc.so.1
(gdb) where
#0  0xfe1b1773 in mutex_lock_impl () from /lib/libc.so.1
#1  0xfe1b1a03 in pthread_mutex_lock () from /lib/libc.so.1
#2  0xfe5d1da4 in __gthread_mutex_lock (__mutex=0x18)
    at ../libgcc/gthr-default.h:748
#3  _gfortran_st_flush (fpp=0xfeffda40)
    at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:514
#4  0x0805106f in flush_1 ()
    at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/flush_1.f90:11
#5  0x080512a7 in main (argc=1, argv=0xfeffdbfa)
    at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/flush_1.f90:28
#6  0x08050de6 in _start ()

I've not yet investigated why they only occur for 32-bit.  I tried the
following snippet to fix them
--- libgfortran/io/file_pos.c.save	2018-07-03 22:48:42.485018736 +0000
+++ libgfortran/io/file_pos.c	2018-07-04 07:51:43.494582145 +0000
@@ -511,7 +511,8 @@ st_flush (st_parameter_filepos *fpp)
       else
 	{
 	  needs_unlock = true;
-	  LOCK (&u->au->io_lock);
+	  if (u->au)
+	    LOCK (&u->au->io_lock);
 	}
 
       /* Make sure format buffer is flushed.  */
which did so indeed, but now there's another failure, again 32-bit only:

FAIL: gfortran.dg/eof_4.f90   -O0  execution test
FAIL: gfortran.dg/eof_4.f90   -O1  execution test
FAIL: gfortran.dg/eof_4.f90   -O2  execution test
FAIL: gfortran.dg/eof_4.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loo
ps -ftracer -finline-functions  execution test
FAIL: gfortran.dg/eof_4.f90   -O3 -g  execution test
FAIL: gfortran.dg/eof_4.f90   -Os  execution test

At line 12 of file /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/eof_4.f90 (unit = 99)
Fortran runtime error: Cannot open file 'test.dat': File exists

Error termination. Backtrace:

	Rainer

Patch
diff mbox series

Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi	(Revision 259739)
+++ gcc/fortran/gfortran.texi	(Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
 
 
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ gcc/fortran/trans-io.c	(Arbeitskopie)
@@ -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 259739)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03	(Arbeitskopie)
@@ -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 259739)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/Makefile.am	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/Makefile.in	(Arbeitskopie)
@@ -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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map	(Arbeitskopie)
@@ -1482,3 +1482,8 @@  GFORTRAN_C99_8 {
     y1f;
     ynf;
 };
+
+GFORTRAN_9 {
+  global:
+  _gfortran_st_wait_async;
+};
Index: libgfortran/io/async.c
===================================================================
--- libgfortran/io/async.c	(nicht existent)
+++ libgfortran/io/async.c	(Arbeitskopie)
@@ -0,0 +1,483 @@ 
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+   Contributed by Nicolas Koenig
+
+   This file is part of the GNU Fortran runtime library (libgfortran).
+
+   Libgfortran is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3, or (at your option)
+   any later version.
+
+   Libgfortran is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   Under Section 7 of GPL version 3, you are granted additional
+   permissions described in the GCC Runtime Library Exception, version
+   3.1, as published by the Free Software Foundation.
+
+   You should have received a copy of the GNU General Public License and
+   a copy of the GCC Runtime Library Exception along with this program;
+   see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#include "libgfortran.h"
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <assert.h>
+
+#include <sys/types.h>
+
+#include "async.h"
+
+DEBUG_LINE (__thread const char *aio_prefix = MPREFIX);
+
+DEBUG_LINE (__gthread_mutex_t debug_queue_lock = __GTHREAD_MUTEX_INIT;)
+DEBUG_LINE (aio_lock_debug *aio_debug_head = NULL;)
+
+/* Current unit for asynchronous I/O.  Needed for error reporting.  */
+
+__thread gfc_unit *thread_unit = NULL;
+
+/* Queue entry for the asynchronous I/O entry.  */
+typedef struct transfer_queue
+{
+  enum aio_do type;
+  struct transfer_queue *next;
+  struct st_parameter_dt *new_pdt;
+  transfer_args arg;
+  _Bool has_id;
+  int read_flag;
+} transfer_queue;
+
+struct error {
+  st_parameter_dt *dtp;
+  int id;
+};
+
+/* Helper function to exchange the old vs. a new PDT.  */
+
+static void
+update_pdt (st_parameter_dt **old, st_parameter_dt *new) {
+  st_parameter_dt *temp;
+  NOTE ("Changing pdts, current_unit = %p", (void *) (new->u.p.current_unit));
+  temp = *old;
+  *old = new;
+  if (temp)
+    free (temp);
+}
+
+/* Destroy an adv_cond structure.  */
+
+static void
+destroy_adv_cond (struct adv_cond *ac)
+{
+  T_ERROR (__gthread_mutex_destroy, &ac->lock);
+  T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+/* Function invoked as start routine for a new asynchronous I/O unit.
+   Contains the main loop for accepting requests and handling them.  */
+
+static void *
+async_io (void *arg)
+{
+  DEBUG_LINE (aio_prefix = TPREFIX);
+  transfer_queue *ctq = NULL, *prev = NULL;
+  gfc_unit *u = (gfc_unit *) arg;
+  async_unit *au = u->au;
+  LOCK (&au->lock);
+  thread_unit = u;
+  au->thread = __gthread_self ();
+  while (true)
+    {
+      /* Main loop.  At this point, au->lock is always held. */
+      WAIT_SIGNAL_MUTEX (&au->work, au->tail != NULL, &au->lock);
+      LOCK (&au->lock);
+      ctq = au->head;
+      prev = NULL;
+      /* Loop over the queue entries until they are finished.  */
+      while (ctq)
+	{
+	  if (prev)
+	    free (prev);
+	  prev = ctq;
+	  if (!au->error.has_error)
+	    {
+	      UNLOCK (&au->lock);
+
+	      switch (ctq->type)
+		{
+		case AIO_WRITE_DONE:
+		  NOTE ("Finalizing write");
+		  st_write_done_worker (au->pdt);
+		  UNLOCK (&au->io_lock);
+		  break;
+
+		case AIO_READ_DONE:
+		  NOTE ("Finalizing read");
+		  st_read_done_worker (au->pdt);
+		  UNLOCK (&au->io_lock);
+		  break;
+
+		case AIO_DATA_TRANSFER_INIT:
+		  NOTE ("Data transfer init");
+		  LOCK (&au->io_lock);
+		  update_pdt (&au->pdt, ctq->new_pdt);
+		  data_transfer_init_worker (au->pdt, ctq->read_flag);
+		  break;
+
+		case AIO_TRANSFER_SCALAR:
+		  NOTE ("Starting scalar transfer");
+		  ctq->arg.scalar.transfer (au->pdt, ctq->arg.scalar.arg_bt,
+					    ctq->arg.scalar.data,
+					    ctq->arg.scalar.i,
+					    ctq->arg.scalar.s1,
+					    ctq->arg.scalar.s2);
+		  break;
+
+		case AIO_TRANSFER_ARRAY:
+		  NOTE ("Starting array transfer");
+		  NOTE ("ctq->arg.array.desc = %p",
+			(void *) (ctq->arg.array.desc));
+		  transfer_array_inner (au->pdt, ctq->arg.array.desc,
+					ctq->arg.array.kind,
+					ctq->arg.array.charlen);
+		  free (ctq->arg.array.desc);
+		  break;
+
+		case AIO_CLOSE:
+		  NOTE ("Received AIO_CLOSE");
+		  goto finish_thread;
+
+		default:
+		  internal_error (NULL, "Invalid queue type");
+		  break;
+		}
+	      LOCK (&au->lock);
+	      if (unlikely (au->error.has_error))
+		au->error.last_good_id = au->id.low - 1;
+	    }
+	  else
+	    {
+	      if (ctq->type == AIO_WRITE_DONE || ctq->type == AIO_READ_DONE)
+		{
+		  UNLOCK (&au->io_lock);
+		}
+	      else if (ctq->type == AIO_CLOSE)
+		{
+		  NOTE ("Received AIO_CLOSE during error condition");
+		  UNLOCK (&au->lock);
+		  goto finish_thread;
+		}
+	    }
+
+  	  NOTE ("Next ctq, current id: %d", au->id.low);
+  	  if (ctq->has_id && au->id.waiting == au->id.low++)
+	    SIGNAL (&au->id.done);
+
+	  ctq = ctq->next;
+	}
+      au->tail = NULL;
+      au->head = NULL;
+      au->empty = 1;
+      UNLOCK (&au->lock);
+      SIGNAL (&au->emptysignal);
+      LOCK (&au->lock);
+    }
+ finish_thread:
+  au->tail = NULL;
+  au->head = NULL;
+  au->empty = 1;
+  SIGNAL (&au->emptysignal);
+  free (ctq);
+  return NULL;
+}
+
+/* Free an asynchronous unit.  */
+
+static void
+free_async_unit (async_unit *au)
+{
+  if (au->tail)
+    internal_error (NULL, "Trying to free nonempty asynchronous unit");
+
+  destroy_adv_cond (&au->work);
+  destroy_adv_cond (&au->emptysignal);
+  destroy_adv_cond (&au->id.done);
+  T_ERROR (__gthread_mutex_destroy, &au->lock);
+  free (au);
+}
+
+/* Initialize an adv_cond structure.  */
+
+static void
+init_adv_cond (struct adv_cond *ac)
+{
+  ac->pending = 0;
+  __GTHREAD_MUTEX_INIT_FUNCTION (&ac->lock);
+  __gthread_cond_init_function (&ac->signal);
+}
+
+/* Initialize an asyncronous unit, returning zero on success,
+ nonzero on failure.  It also sets u->au.  */
+
+void
+init_async_unit (gfc_unit *u)
+{
+  async_unit *au;
+  if (!__gthread_active_p ())
+    {
+      u->au = NULL;
+      return;
+    }
+  
+  au = (async_unit *) xmalloc (sizeof (async_unit));
+  u->au = au;
+  init_adv_cond (&au->work);
+  init_adv_cond (&au->emptysignal);
+  __GTHREAD_MUTEX_INIT_FUNCTION (&au->lock);
+  __GTHREAD_MUTEX_INIT_FUNCTION (&au->io_lock);
+  LOCK (&au->lock);
+  T_ERROR (__gthread_create, &au->thread, &async_io, (void *) u);
+  au->pdt = NULL;
+  au->head = NULL;
+  au->tail = NULL;
+  au->empty = true;
+  au->id.waiting = -1;
+  au->id.low = 0;
+  au->id.high = 0;
+  au->error.fatal_error = 0;
+  au->error.has_error = 0;
+  au->error.last_good_id = 0;
+  init_adv_cond (&au->id.done);
+  UNLOCK (&au->lock);
+}
+
+/* Enqueue a transfer statement.  */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+  tq->arg = *arg;
+  tq->type = type;
+  tq->has_id = 0;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Enqueue an st_write_done or st_read_done which contains an ID.  */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+  int ret;
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+  tq->type = type;
+  tq->has_id = 1;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  ret = au->id.high++;
+  NOTE ("Enqueue id: %d", ret);
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+  return ret;
+}
+
+/* Enqueue an st_write_done or st_read_done without an ID.  */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+  tq->type = type;
+  tq->has_id = 0;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Enqueue a CLOSE statement.  */
+
+void
+enqueue_close (async_unit *au)
+{
+  transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+  tq->type = AIO_CLOSE;
+  LOCK (&au->lock);
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = false;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* The asynchronous unit keeps the currently active PDT around.
+   This function changes that to the current one.  */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+  st_parameter_dt *new = xmalloc (sizeof (st_parameter_dt));
+  transfer_queue *tq = xmalloc (sizeof (transfer_queue));
+
+  memcpy ((void *) new, (void *) dt, sizeof (st_parameter_dt));
+
+  NOTE ("dt->internal_unit_desc = %p", dt->internal_unit_desc);
+  NOTE ("common.flags & mask = %d", dt->common.flags & IOPARM_LIBRETURN_MASK);
+  tq->next = NULL;
+  tq->type = AIO_DATA_TRANSFER_INIT;
+  tq->read_flag = read_flag;
+  tq->has_id = 0;
+  tq->new_pdt = new;
+  LOCK (&au->lock);
+
+  if (!au->tail)
+    au->head = tq;
+  else
+    au->tail->next = tq;
+  au->tail = tq;
+  REVOKE_SIGNAL (&(au->emptysignal));
+  au->empty = 0;
+  UNLOCK (&au->lock);
+  SIGNAL (&au->work);
+}
+
+/* Collect the errors that may have happened asynchronously.  Return true if
+   an error has been encountered.  */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+  bool has_error = au->error.has_error;
+
+  if (has_error)
+    {
+      if (generate_error_common (cmp, au->error.family, au->error.message))
+	{
+	  au->error.has_error = 0;
+	  au->error.cmp = NULL;
+	}
+      else
+	{
+	  /* The program will exit later.  */
+	  au->error.fatal_error = true;
+	}
+    }
+  return has_error;
+}
+
+/* Perform a wait operation on an asynchronous unit with an ID specified,
+   which means collecting the errors that may have happened asynchronously.
+   Return true if an error has been encountered.  */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+  bool ret;
+
+  if (au == NULL)
+    return false;
+
+  if (cmp == NULL)
+    cmp = au->error.cmp;
+
+  if (au->error.has_error)
+    {
+      if (i <= au->error.last_good_id)
+	return false;
+
+      return collect_async_errors (cmp, au);
+    }
+
+  LOCK (&au->lock);
+  NOTE ("Waiting for id %d", i);
+  if (au->id.waiting < i)
+    au->id.waiting = i;
+  UNLOCK (&au->lock);
+  SIGNAL (&(au->work));
+  LOCK (&au->lock);
+  WAIT_SIGNAL_MUTEX (&(au->id.done),
+		     (au->id.low >= au->id.waiting || au->empty), &au->lock);
+  LOCK (&au->lock);
+  ret = collect_async_errors (cmp, au);
+  UNLOCK (&au->lock);
+  return ret;
+}
+
+/* Perform a wait operation an an asynchronous unit without an ID.  */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+  bool ret;
+
+  if (au == NULL)
+    return false;
+
+  if (cmp == NULL)
+    cmp = au->error.cmp;
+
+  SIGNAL (&(au->work));
+  LOCK (&(au->lock));
+
+  if (au->empty)
+    {
+      ret = collect_async_errors (cmp, au);
+      UNLOCK (&au->lock);
+      return ret;
+    }
+
+  WAIT_SIGNAL_MUTEX (&(au->emptysignal), (au->empty), &au->lock);
+  ret = collect_async_errors (cmp, au);
+  return ret;
+}
+
+/* Close an asynchronous unit.  */
+
+void
+async_close (async_unit *au)
+{
+  if (au == NULL)
+    return;
+
+  NOTE ("Closing async unit");
+  enqueue_close (au);
+  T_ERROR (__gthread_join, au->thread, NULL);
+  free_async_unit (au);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h	(nicht existent)
+++ libgfortran/io/async.h	(Arbeitskopie)
@@ -0,0 +1,378 @@ 
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+   Contributed by Nicolas Koenig
+
+   This file is part of the GNU Fortran runtime library (libgfortran).
+
+   Libgfortran is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3, or (at your option)
+   any later version.
+
+   Libgfortran is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   Under Section 7 of GPL version 3, you are granted additional
+   permissions described in the GCC Runtime Library Exception, version
+   3.1, as published by the Free Software Foundation.
+
+   You should have received a copy of the GNU General Public License and
+   a copy of the GCC Runtime Library Exception along with this program;
+   see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#ifndef ASYNC_H
+#define ASYNC_H
+
+/* Defining DEBUG_ASYNC will enable somewhat verbose debugging
+   output for async I/O.  */
+
+#define DEBUG_ASYNC
+#undef DEBUG_ASYNC
+
+#ifdef DEBUG_ASYNC
+
+/* Define this if you want to use ANSI color escape sequences in your
+   debugging output.  */
+
+#define DEBUG_COLOR
+
+#ifdef DEBUG_COLOR
+#define MPREFIX "\033[30;46mM:\033[0m "
+#define TPREFIX "\033[37;44mT:\033[0m "
+#define RPREFIX "\033[37;41mR:\033[0m "
+#define DEBUG_RED "\033[31m"
+#define DEBUG_ORANGE "\033[33m"
+#define DEBUG_GREEN "\033[32m"
+#define DEBUG_DARKRED "\033[31;2m"
+#define DEBUG_PURPLE "\033[35m"
+#define DEBUG_NORM "\033[0m"
+#define DEBUG_REVERSE_RED "\033[41;37m"
+#define DEBUG_BLUE "\033[34m"
+
+#else
+
+#define MPREFIX "M: "
+#define TPREFIX "T: "
+#define RPREFIX ""
+#define DEBUG_RED ""
+#define DEBUG_ORANGE ""
+#define DEBUG_GREEN ""
+#define DEBUG_DARKRED ""
+#define DEBUG_PURPLE ""
+#define DEBUG_NORM ""
+#define DEBUG_REVERSE_RED ""
+#define DEBUG_BLUE ""
+
+#endif
+
+#define DEBUG_PRINTF(...) fprintf (stderr,__VA_ARGS__)
+
+#define IN_DEBUG_QUEUE(mutex) ({		\
+      __label__ end;				\
+      aio_lock_debug *curr = aio_debug_head;	\
+      while (curr) {				\
+	if (curr->m == mutex) {			\
+	  goto end;				\
+	}					\
+	curr = curr->next;			\
+      }						\
+    end:;					\
+      curr;					\
+    })
+
+#define TAIL_DEBUG_QUEUE ({			\
+      aio_lock_debug *curr = aio_debug_head;	\
+      while (curr && curr->next) {		\
+	curr = curr->next;			\
+      }						\
+      curr;					\
+    })
+
+#define CHECK_LOCK(mutex, status) do {					\
+    aio_lock_debug *curr;						\
+    INTERN_LOCK (&debug_queue_lock);					\
+    if (__gthread_mutex_trylock (mutex)) {				\
+      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 {								\
+      __gthread_mutex_unlock (mutex);					\
+      sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM);			\
+    }									\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+  }while (0)
+
+#define T_ERROR(func, ...) do {				\
+    int t_error_temp;					\
+    t_error_temp = func(__VA_ARGS__);			\
+    if (t_error_temp)					\
+      ERROR (t_error_temp, "args: " #__VA_ARGS__ "\n");	\
+  } while (0)
+
+#define NOTE(str, ...) do{						\
+    char note_str[200];							\
+    sprintf (note_str, "%s" DEBUG_PURPLE "NOTE: " DEBUG_NORM str, aio_prefix, ##__VA_ARGS__); \
+    DEBUG_PRINTF ("%-90s %20s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+  }while (0);
+
+#define ERROR(errnum, str, ...) do{					\
+    char note_str[200];							\
+    sprintf (note_str, "%s" DEBUG_REVERSE_RED "ERROR:" DEBUG_NORM " [%d] " str, aio_prefix, \
+	    errnum, ##__VA_ARGS__);					\
+    DEBUG_PRINTF ("%-68s %s():%-5d\n", note_str, __FUNCTION__, __LINE__);	\
+  }while (0)
+
+#define MUTEX_DEBUG_ADD(mutex) do {		\
+    aio_lock_debug *n;				\
+    n = malloc (sizeof(aio_lock_debug));	\
+    n->prev = TAIL_DEBUG_QUEUE;			\
+    if (n->prev)				\
+      n->prev->next = n;			\
+    n->next = NULL;				\
+    n->line = __LINE__;				\
+    n->func = __FUNCTION__;			\
+    n->m = mutex;				\
+    if (!aio_debug_head) {			\
+      aio_debug_head = n;			\
+    }						\
+  } while (0)
+
+#define UNLOCK(mutex) do {						\
+    aio_lock_debug *curr;						\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_GREEN "UNLOCK: " DEBUG_NORM #mutex, \
+		 __FUNCTION__, __LINE__, (void *) mutex);		\
+    INTERN_LOCK (&debug_queue_lock);					\
+    curr = IN_DEBUG_QUEUE (mutex);					\
+    if (curr)								\
+      {									\
+	if (curr->prev)							\
+	  curr->prev->next = curr->next;				\
+	if (curr->next) {						\
+	  curr->next->prev = curr->prev;				\
+	  if (curr == aio_debug_head)					\
+	    aio_debug_head = curr->next;				\
+	} else {							\
+	  if (curr == aio_debug_head)					\
+	    aio_debug_head = NULL;					\
+	}								\
+	free (curr);							\
+      }									\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+    INTERN_UNLOCK (mutex);						\
+  }while (0)
+
+#define TRYLOCK(mutex) ({						\
+			 char status[200];				\
+			 int res;					\
+			 aio_lock_debug *curr;				\
+			 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 #mutex, status, __FUNCTION__, __LINE__, \
+				      (void *) mutex);			\
+			 INTERN_UNLOCK (&debug_queue_lock);		\
+			 res;						\
+    })
+
+#define LOCK(mutex) do {						\
+    char status[200];							\
+    CHECK_LOCK (mutex, status);						\
+    DEBUG_PRINTF ("%s%-42s prev: %-35s %20s():%-5d %18p\n", aio_prefix,	\
+		 DEBUG_RED "LOCK: " DEBUG_NORM #mutex, status, __FUNCTION__, __LINE__, (void *) mutex); \
+    INTERN_LOCK (mutex);							\
+    INTERN_LOCK (&debug_queue_lock);					\
+    MUTEX_DEBUG_ADD (mutex);						\
+    INTERN_UNLOCK (&debug_queue_lock);					\
+    DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
+  } while (0)
+
+#define DEBUG_LINE(...) __VA_ARGS__
+
+#else
+#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)
+#define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+#define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+#endif
+
+#define INTERN_LOCK(mutex) T_ERROR (__gthread_mutex_lock, mutex);
+
+#define INTERN_UNLOCK(mutex) T_ERROR (__gthread_mutex_unlock, mutex);
+
+#define SIGNAL(advcond) do{						\
+    INTERN_LOCK (&(advcond)->lock);					\
+    (advcond)->pending = 1;						\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "SIGNAL: " DEBUG_NORM \
+		 #advcond, __FUNCTION__, __LINE__, (void *) advcond);	\
+    T_ERROR (__gthread_cond_broadcast, &(advcond)->signal);		\
+    INTERN_UNLOCK (&(advcond)->lock);					\
+  } while (0)
+
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{		\
+    __label__ finish;		       					\
+    INTERN_LOCK (&((advcond)->lock));					\
+    DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_BLUE "WAITING: " DEBUG_NORM \
+		 #advcond, __FUNCTION__, __LINE__, (void *) advcond);	\
+    if ((advcond)->pending || (condition)){				\
+      UNLOCK (mutex);							\
+      goto finish;							\
+    }									\
+    UNLOCK (mutex);							\
+     while (!__gthread_cond_wait(&(advcond)->signal, &(advcond)->lock)) {	\
+       { int cond;							\
+	 LOCK (mutex); cond = condition; UNLOCK (mutex);	\
+	   if (cond){							\
+	     DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "REC: " DEBUG_NORM \
+		  #advcond,  __FUNCTION__, __LINE__, (void *)advcond);	\
+	   break;				      			\
+        }							\
+      }									\
+    }									\
+  finish:								\
+		 (advcond)->pending = 0;				\
+		 INTERN_UNLOCK (&((advcond)->lock));			\
+		 } while (0)
+
+#define REVOKE_SIGNAL(advcond) do{		\
+    INTERN_LOCK (&(advcond)->lock);		\
+    (advcond)->pending = 0;			\
+    INTERN_UNLOCK (&(advcond)->lock);		\
+  } while (0)
+
+DEBUG_LINE (extern __thread const char *aio_prefix);
+
+DEBUG_LINE (typedef struct aio_lock_debug{
+  __gthread_mutex_t *m;
+  int line;
+  const char *func;
+  struct aio_lock_debug *next;
+  struct aio_lock_debug *prev;
+} aio_lock_debug;)
+
+DEBUG_LINE (extern aio_lock_debug *aio_debug_head;)
+DEBUG_LINE (extern __gthread_mutex_t debug_queue_lock;)
+
+/* Thread - local storage of the current unit we are looking at. Needed for
+   error reporting.  */
+
+extern __thread gfc_unit *thread_unit;
+
+enum aio_do {
+  AIO_INVALID = 0,
+  AIO_DATA_TRANSFER_INIT,
+  AIO_TRANSFER_SCALAR,
+  AIO_TRANSFER_ARRAY,
+  AIO_WRITE_DONE,
+  AIO_READ_DONE,
+  AIO_CLOSE
+};
+
+typedef union transfer_args
+{
+  struct
+  {
+    void (*transfer) (struct st_parameter_dt *, bt, void *, int, size_t, size_t);
+    bt arg_bt;
+    void *data;
+    int i;
+    size_t s1;
+    size_t s2;
+  } scalar;
+  struct
+  {
+    gfc_array_char *desc;
+    int kind;
+    gfc_charlen_type charlen;
+  } array;
+} transfer_args;
+
+struct adv_cond
+{
+  int pending;
+  __gthread_mutex_t lock;
+  __gthread_cond_t signal;
+};
+
+typedef struct async_unit
+{
+  pthread_mutex_t lock;      /* Lock for manipulating the queue structure.  */
+  pthread_mutex_t io_lock;   /* Lock for doing actual I/O. */
+  struct adv_cond work;
+  struct adv_cond emptysignal;
+  struct st_parameter_dt *pdt;
+  pthread_t thread;
+  struct transfer_queue *head;
+  struct transfer_queue *tail;
+  struct
+  {
+    int waiting;
+    int low;
+    int high;
+    struct adv_cond done;
+  } id;
+
+  bool empty;
+
+  struct {
+    const char *message;
+    st_parameter_common *cmp;
+    bool has_error;
+    int last_good_id;
+    int family;
+    bool fatal_error;
+  } error;
+
+} async_unit;
+
+void init_async_unit (gfc_unit *);
+internal_proto (init_async_unit);
+
+bool async_wait (st_parameter_common *, async_unit *);
+internal_proto (async_wait);
+
+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); 
+
+void async_close (async_unit *);
+internal_proto (async_close);
+
+void enqueue_transfer (async_unit * au, transfer_args * arg, enum aio_do);
+internal_proto (enqueue_transfer);
+
+void enqueue_done (async_unit *, enum aio_do type);
+internal_proto (enqueue_done);
+
+int enqueue_done_id (async_unit *, enum aio_do type);
+internal_proto (enqueue_done_id);
+
+void enqueue_init (async_unit *);
+internal_proto (enqueue_init);
+
+void enqueue_data_transfer_init (async_unit *, st_parameter_dt *, int);
+internal_proto (enqueue_data_transfer_init);
+
+void enqueue_close (async_unit *);
+internal_proto (enqueue_close);
+
+#endif
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c	(Revision 259739)
+++ libgfortran/io/close.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/file_pos.c	(Arbeitskopie)
@@ -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 (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 (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 (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 (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 (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 (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,14 @@  st_flush (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
+      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 +527,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 259739)
+++ libgfortran/io/inquire.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/io.h	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/open.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/read.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/io/transfer.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/unit.c	(Arbeitskopie)
@@ -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 (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 259739)
+++ libgfortran/io/unix.c	(Arbeitskopie)
@@ -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 259739)
+++ libgfortran/libgfortran.h	(Arbeitskopie)
@@ -743,6 +743,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);
 
@@ -1748,5 +1751,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 259739)
+++ libgfortran/runtime/error.c	(Arbeitskopie)
@@ -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,38 @@  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];
+  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;
+	}
+    }
+
   /* 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 +579,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 +609,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);