Hey everyone,

Thomas and I have been working on adding asynchronous I/O to libgfortran. The patch is almost done, the only thing still missing is to link libgfortran against libpthread if it exists(which is for some reason necessary despite using __gthread) and deactivating it if libpthread doesn't exist (MinGW). At the moment it is still required to explicitly link against libpthread with -pthread when a program is compiled. Because of this we weren't able to run regression tests yet, since every single test fails.

It would be great if somebody else could try the patch and report their experiences. Also, if anyone knows how to add the whole conditional libpthread thing in the build script, a little help would be very welcome.

    Nicolas

P.S.: I have a new email address, the old one has some problems.

Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(Revision 259739)
+++ gcc/fortran/trans-io.c	(Arbeitskopie)
@@ -1527,7 +1527,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: 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/io/async.c
===================================================================
--- libgfortran/io/async.c	(nicht existent)
+++ libgfortran/io/async.c	(Arbeitskopie)
@@ -0,0 +1,380 @@
+/* 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/>.  */
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr-posix.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);
+
+__thread gfc_unit *thread_unit = NULL;
+
+typedef struct transfer_queue
+{
+  enum aio_do type;
+  struct transfer_queue *next;
+  struct st_parameter_dt *new_pdt;
+  transfer_args arg;
+  _Bool has_id;
+} transfer_queue;
+
+struct error {
+  st_parameter_dt *dtp;
+  int id;
+};
+
+static void
+update_pdt(st_parameter_dt **old, st_parameter_dt *new) {
+  st_parameter_dt *temp;
+  NOTE("Changing pdts");
+  temp = *old;
+  *old = new;
+  if(temp)
+    free(temp);
+}
+
+static void
+destroy_adv_cond (struct adv_cond * ac)
+{
+  T_ERROR (__gthread_mutex_destroy, &ac->lock);
+  T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+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;
+  thread_unit = u;
+  LOCK (au, lock);
+  au->thread = __gthread_self ();
+  UNLOCK (au, lock);
+  while (true)
+    {
+      WAIT_SIGNAL (&au->work, au->tail || au->finished);
+      LOCK (au, lock);
+      ctq = au->head;
+      prev = NULL;
+      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); 
+		  break;
+		case AIO_READ_DONE:
+		  NOTE("Finalizing read");
+		  st_read_done_worker (au->pdt);
+		  break;
+		case AIO_CHANGE_PDT: 
+		  update_pdt(&au->pdt, ctq->new_pdt); 
+		  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");
+		  transfer_array_inner(au->pdt, ctq->arg.array.desc, 
+				       ctq->arg.array.kind, 
+				       ctq->arg.array.charlen);
+		  break;
+		default:
+		  ERROR(-1, "Invalid queue type %d", ctq->type);
+		  break;
+		}
+	      LOCK (au, lock);
+	      if (unlikely (au->error.has_error))
+		{
+		  au->error.last_good_id = au->id.low - 1;
+		  unlock_unit (au->pdt->u.p.current_unit);
+		}
+	    }
+  	  NOTE("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;
+      SIGNAL (&au->emptysignal);
+      au->empty = 1;
+      if (au->finished)
+	break;
+      UNLOCK (au, lock);
+    }
+  UNLOCK (au, lock);
+  return NULL;
+}
+
+
+static void
+free_async_unit (async_unit * au)
+{
+  if (au->tail)
+    ERROR (1, "Trying to free nonempty 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);
+}
+
+static void
+init_adv_cond (struct adv_cond * ac)
+{
+  ac->pending = 0;
+  __GTHREAD_MUTEX_INIT_FUNCTION(&ac->lock);
+  __GTHREAD_COND_INIT_FUNCTION(&ac->signal);
+}
+
+async_unit *
+init_async_unit (gfc_unit *u)
+{
+  async_unit *au;
+  au = (async_unit *) malloc (sizeof (async_unit));
+  u->au = au;
+  init_adv_cond (&au->work);
+  init_adv_cond (&au->emptysignal);
+  __GTHREAD_MUTEX_INIT_FUNCTION(&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->finished = 0;
+  au->id.waiting = -1;
+  au->id.low = 0;
+  au->id.high = 0;
+  init_adv_cond (&au->id.done);
+  return au;
+}
+
+
+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);
+}
+
+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;
+}
+
+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);  
+}
+
+void
+change_pdt (async_unit *au, st_parameter_dt *dt) {
+  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));
+  tq->next = NULL;
+  tq->new_pdt = new;
+  tq->type = AIO_CHANGE_PDT;
+  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 = 0;
+  UNLOCK(au, lock);
+  SIGNAL(&au->work);
+}
+
+/* Perform a wait operation on an asynchronous unit, which means collecting
+   the errors that may have happened asynchronously.  Return true if an error
+   has been encountered.  */
+
+static bool
+async_wait_operation (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 async_wait_operation (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));
+  WAIT_SIGNAL (&(au->id.done), (au->id.low >= au->id.waiting || au->empty));
+  LOCK (au, lock);
+  ret = async_wait_operation (cmp, au);
+  UNLOCK(au, lock);
+  return ret;
+}
+
+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 = async_wait_operation (cmp, au);
+      UNLOCK(au, lock);
+      return ret;
+    }
+
+  UNLOCK(au, lock);  
+  WAIT_SIGNAL (&(au->emptysignal), (au->empty));
+  LOCK (au, lock);
+  ret = async_wait_operation (cmp, au);
+  UNLOCK(au, lock);
+  return ret;
+}
+
+void
+async_close (async_unit * au)
+{
+  NOTE("Closing async unit");
+  if (!au->error.fatal_error)
+    {
+      LOCK (au, lock);
+      au->finished = 1;
+      UNLOCK (au, lock);
+      async_wait (NULL, 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,226 @@
+/* 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
+
+#define DEBUG_ASYNC
+#undef DEBUG_ASYNC
+
+#ifdef DEBUG_ASYNC
+#define DEBUG_PRINTF(...) fprintf(stderr,__VA_ARGS__)
+#define CHECK_LOCK(au, mutex, status) do {\
+	if (__gthread_mutex_trylock(& au -> mutex))\
+	  status = "\033[31mlocked\033[0m";\
+	else {\
+	  __gthread_mutex_unlock(& au -> mutex);\
+	  status = "\033[32munlocked\033[0m";\
+	}\
+	}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\033[35mNOTE: \033[0m" str, aio_prefix, ##__VA_ARGS__);\
+	DEBUG_PRINTF("%-80s %s():%d\n", note_str, __FUNCTION__, __LINE__);\
+	}while(0);
+#define ERROR(errnum, str, ...) do{\
+	char note_str[200];\
+	sprintf(note_str, "%s\033[41;37mERROR:\033[0m [%d] " str, aio_prefix, \
+	  errnum, ##__VA_ARGS__);\
+	DEBUG_PRINTF("%-68s %s():%d\n", note_str, __FUNCTION__, __LINE__);\
+	}while(0)
+#define DEBUG_LINE(line) line
+#else
+#define DEBUG_PRINTF(...) {}
+#define CHECK_LOCK(au, mutex, status) {}
+#define NOTE(str, ...) {}
+#define ERROR(errnum, str, ...) {}
+#define DEBUG_LINE(line)
+#define T_ERROR(func, ...) func(__VA_ARGS__)
+#endif
+
+#define MPREFIX "\033[30;46mM:\033[0m "
+#define TPREFIX "\033[37;44mT:\033[0m "
+#define RPREFIX "\033[37;41mR:\033[0m "
+
+#define INTERN_LOCK(mutex) T_ERROR(__gthread_mutex_lock, mutex);
+
+#define INTERN_UNLOCK(mutex) T_ERROR(__gthread_mutex_unlock, mutex);
+
+#define UNLOCK(au, mutex) do {\
+	DEBUG_PRINTF("%s%-65s %s():%d\n", aio_prefix, "\033[32mUNLOCK: \033[0m" #mutex, \
+	  __FUNCTION__, __LINE__);\
+	INTERN_UNLOCK(& au -> mutex);\
+	}while(0)
+
+
+#define LOCK(au, mutex) do {\
+	DEBUG_LINE(const char *status);\
+	CHECK_LOCK(au, mutex, status);\
+	DEBUG_PRINTF("%s%-42s prev: %-25s %s():%d\n", aio_prefix, \
+	  "\033[31mLOCK: \033[0m" #mutex, status, __FUNCTION__, __LINE__);\
+	INTERN_LOCK(&au->mutex);\
+	DEBUG_PRINTF("%s\033[31mACQ:\033[0m " #mutex "\n", aio_prefix);\
+	}while(0)
+
+#define SIGNAL(advcond) do{\
+	INTERN_LOCK(&(advcond)->lock);\
+	(advcond)->pending = 1;\
+	INTERN_UNLOCK(&(advcond)->lock);\
+	DEBUG_PRINTF("%s%-65s %s():%d\n", aio_prefix, "\033[33mSIGNAL: \033[0m" \
+	  #advcond, __FUNCTION__, __LINE__);\
+	T_ERROR(__gthread_cond_broadcast, &(advcond)->signal);\
+	}while(0)
+
+#define WAIT_SIGNAL(advcond, condition) do{\
+	__label__ finish;\
+	INTERN_LOCK(&((advcond)->lock));\
+	DEBUG_PRINTF("%s%-65s %s():%d\n", aio_prefix, "\033[34mWAITING: \033[0m" \
+	  #advcond, __FUNCTION__, __LINE__);\
+	if ((advcond)->pending){\
+	  goto finish;\
+ 	}\
+	if ( condition ) {\
+	  goto finish; \
+	}\
+	while(!__gthread_cond_wait(&(advcond)->signal, &(advcond)->lock)) {\
+	  if ( condition ){\
+	    DEBUG_PRINTF("%s%-65s %s():%d\n", aio_prefix, "\033[33mREC: \033[0m" \
+		   #advcond,  __FUNCTION__, __LINE__);\
+	    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);
+
+extern __thread gfc_unit *thread_unit;
+
+enum aio_do {
+  AIO_INVALID = 0,
+  AIO_CHANGE_PDT,
+  AIO_TRANSFER_SCALAR,
+  AIO_TRANSFER_ARRAY,
+  AIO_WRITE_DONE,
+  AIO_READ_DONE
+};
+
+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;
+  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;
+
+  int finished;
+  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;
+
+async_unit *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);
+
+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 change_pdt(async_unit *, st_parameter_dt *);
+internal_proto(change_pdt);
+#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/fbuf.c
===================================================================
--- libgfortran/io/fbuf.c	(Revision 259739)
+++ libgfortran/io/fbuf.c	(Arbeitskopie)
@@ -29,7 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
 #include <string.h>
 
 
-//#define FBUF_DEBUG
+// #define FBUF_DEBUG
 
 
 void
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,
@@ -214,6 +215,9 @@ st_backspace (st_parameter_filepos *fpp)
       goto done;
     }
 
+  if (u->au && async_wait (&(fpp->common), u->au))
+    return;
+
   /* Make sure format buffer is flushed and reset.  */
   if (u->flags.form == FORM_FORMATTED)
     {
@@ -294,6 +298,9 @@ st_endfile (st_parameter_filepos *fpp)
 	  goto done;
 	}
 
+      if (u->au && async_wait (&(fpp->common), u->au))
+	return;
+
       if (u->flags.access == ACCESS_SEQUENTIAL
       	  && u->endfile == AFTER_ENDFILE)
 	{
@@ -401,6 +408,10 @@ st_rewind (st_parameter_filepos *fpp)
 			"Cannot REWIND a file opened for DIRECT access");
       else
 	{
+
+	  if (u->au && async_wait (&(fpp->common), u->au))
+	    return;
+
 	  /* If there are previously written bytes from a write with ADVANCE="no",
 	     add a record marker before performing the ENDFILE.  */
 
@@ -456,6 +467,9 @@ st_flush (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
+      if (u->au && async_wait (&(fpp->common), u->au))
+	return;
+
       /* Make sure format buffer is flushed.  */
       if (u->flags.form == FORM_FORMATTED)
         fbuf_flush (u, u->mode);
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
@@ -820,6 +825,10 @@ export_proto(st_wait);
 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 +997,13 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
 
 #endif
 
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+extern void
+st_write_done_worker (st_parameter_dt *dtp);
+internal_proto (st_write_done_worker);
+
+extern void
+st_read_done_worker (st_parameter_dt *dtp);
+internal_proto (st_read_done_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)
+    u->au = init_async_unit (u);  
+  else
+    u->au = NULL;
+
   return u;
 
  cleanup:
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
@@ -2281,7 +2288,43 @@ 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->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;
+	}
+      else
+	{
+	  // WAIT
+	  // Hole den letzten Error, wenn einer da ist, dann rausgehen.
+	}
+    }
+  /* 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 +2332,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 +2348,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 +2360,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 +2384,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 +2408,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 +2424,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 +2434,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];
@@ -2471,6 +2510,35 @@ 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->au)
+    {
+      if (dtp->u.p.async)
+	{
+	  transfer_args args;
+	  args.array.desc = desc;
+	  args.array.kind = kind; 
+	  args.array.charlen = charlen;
+	  enqueue_transfer(dtp->u.p.current_unit->au, &args, AIO_TRANSFER_ARRAY);
+	  return;
+	}
+      else
+	{
+	  // WAIT
+	  // Hole den letzten Error, wenn einer da ist, dann rausgehen.
+	}
+    }
+  /* 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 +2560,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);
 }
 
 
@@ -2770,6 +2838,29 @@ 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->au == NULL)
+	{
+	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+			  "ASYNCHRONOUS transfer without ASYHCRONOUS='YES' in OPEN");
+	  return;
+	}
+      dtp->u.p.async = f == ASYNC_YES;
+    }
+
+  /* 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 (dtp->u.p.current_unit->au && !dtp->u.p.async)
+    {
+      if (async_wait (&(dtp->common), dtp->u.p.current_unit->au))
+	return;
+    }
+
   /* Check the action.  */
 
   if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@@ -3184,6 +3275,9 @@ data_transfer_init (st_parameter_dt *dtp, int read
 	dtp->u.p.current_unit->read_bad = 1;
     }
 
+  if (dtp->u.p.current_unit->au)
+    change_pdt(dtp->u.p.current_unit->au, dtp); 
+
   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
     {
 #ifdef HAVE_USELOCALE
@@ -4099,7 +4193,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);
 
@@ -4133,6 +4227,20 @@ void
   library_end ();
 }
 
+void
+st_read_done(st_parameter_dt *dtp) 
+{
+  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);
+    }
+  else
+    st_read_done_worker (dtp);
+}
+
 extern void st_write (st_parameter_dt *);
 export_proto(st_write);
 
@@ -4143,11 +4251,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);
 
@@ -4201,11 +4307,35 @@ void
   library_end ();
 }
 
+void
+st_write_done (st_parameter_dt *dtp)
+{
+  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);
+    }
+  else
+    st_write_done_worker (dtp);
+}
 
-/* F2003: This is a stub for the runtime portion of the WAIT statement.  */
+/* Wait operation.  */
+
 void
-st_wait (st_parameter_wait *wtp __attribute__((unused)))
+st_wait (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); 
 }
 
 
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>
 
@@ -723,6 +724,9 @@ close_unit_1 (gfc_unit *u, int locked)
     finish_last_advance_record (u);
 
   rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
+  
+  if(u->au)
+    async_close (u->au);
 
   u->closed = 1;
   if (!locked)
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);
 
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c	(Revision 259739)
+++ libgfortran/runtime/error.c	(Arbeitskopie)
@@ -24,6 +24,8 @@ 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 +528,30 @@ 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;
 
+  u = thread_unit;
+  if (u && u->au && __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))
@@ -553,7 +561,7 @@ translate_error (int code)
     message =
       (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
       translate_error (family);
-
+ 
   if (cmp->flags & IOPARM_HAS_IOMSG)
     cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 
@@ -564,26 +572,27 @@ translate_error (int code)
     case LIBERROR_EOR:
       cmp->flags |= IOPARM_LIBRETURN_EOR;
       if ((cmp->flags & IOPARM_EOR))
-	return;
+	return true;
       break;
 
     case LIBERROR_END:
       cmp->flags |= IOPARM_LIBRETURN_END;
       if ((cmp->flags & IOPARM_END))
-	return;
+	return true;
       break;
 
     default:
       cmp->flags |= IOPARM_LIBRETURN_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 */
 
   recursion_check ();
@@ -591,8 +600,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);
 
 

Reply via email to