[Patch, Fortran] Add runtime_error function to libgfortran/caf/mpi.c

[Tobias Burnus]

This patch adds a run-time error function to mpi.c, which gives a proper 
error message including the image number. Additionally, it allows to 
clean up the error handling, avoiding the duplicated declaration of strings.

I have not touched the SYNC functions; they can be handled either after 
the committal of the patch at 
http://gcc.gnu.org/ml/fortran/2011-07/msg00074.html - or they can be 
handled by a replacement patch for the latter.

OK for the trunk?

Tobias
2011-07-09  Tobias Burnus  <bur...@net-b.de>

	* caf/mpi.c (runtime_error): New function.
	(_gfortran_caf_register): Use it.

diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c
index 4e3a7eb..d916478 100644
--- a/libgfortran/caf/mpi.c
+++ b/libgfortran/caf/mpi.c
@@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>	/* For memcpy.  */
+#include <stdarg.h>	/* For variadic arguments.  */
 #include <mpi.h>
 
 
@@ -46,6 +47,25 @@ static int caf_is_finalized;
 caf_static_t *caf_static_list = NULL;
 
 
+static void
+runtime_error (int error, const char *message, ...)
+{
+  va_list ap;
+  fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image);
+  va_start (ap, message);
+  fprintf (stderr, message, ap);
+  va_end (ap);
+  fprintf (stderr, "\n");
+
+  /* FIXME: Shutdown the Fortran RTL to flush the buffer.  PR 43849.  */
+  /* FIXME: Do some more effort than just MPI_ABORT.  */
+  MPI_Abort (MPI_COMM_WORLD, error);
+
+  /* Should be unreachable, but to make sure also call exit.  */
+  exit (2);
+}
+
+
 /* Initialize coarray program.  This routine assumes that no other
    MPI initialization happened before; otherwise MPI_Initialized
    had to be used.  As the MPI library might modify the command-line
@@ -138,34 +158,30 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
   return local;
 
 error:
-  if (stat)
-    {
-      *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
-      if (errmsg_len > 0)
-	{
-	  char *msg;
-	  if (caf_is_finalized)
-	    msg = "Failed to allocate coarray - stopped images";
-	  else
-	    msg = "Failed to allocate coarray";
-	  int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
-						      : (int) strlen (msg);
-	  memcpy (errmsg, msg, len);
-	  if (errmsg_len > len)
-	    memset (&errmsg[len], ' ', errmsg_len-len);
-	}
-      return NULL;
-    }
-  else
-    {
-      if (caf_is_finalized)
-	fprintf (stderr, "ERROR: Image %d is stopped, failed to allocate "
-		 "coarray", caf_this_image);
-      else
-	fprintf (stderr, "ERROR: Failed to allocate coarray on image %d\n",
-		 caf_this_image);
-      error_stop (1);
-    }
+  {
+    char *msg;
+    if (caf_is_finalized)
+      msg = "Failed to allocate coarray - there are stopped images";
+    else
+      msg = "Failed to allocate coarray";
+
+    if (stat)
+      {
+	*stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1;
+	if (errmsg_len > 0)
+	  {
+	    int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len
+							: (int) strlen (msg);
+	    memcpy (errmsg, msg, len);
+	    if (errmsg_len > len)
+	      memset (&errmsg[len], ' ', errmsg_len-len);
+	  }
+      }
+    else
+      runtime_error (caf_is_finalized ? STAT_STOPPED_IMAGE : 1, msg);
+  }
+
+  return NULL;
 }