[Fortran] First patch for coarray FAILED IMAGES (TS 18508)

commit a5750c4835566687505c34f73562c7cc3b220841
Author: Alessandro Fanfarillo <elfanfa@ucar.edu>
Date:   Wed Sep 21 12:00:50 2016 -0600

    Third review of failed images patch

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ff5e80b..110bec0 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1217,6 +1217,82 @@  gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
   return true;
 }
 
+bool
+gfc_check_image_status (gfc_expr *image, gfc_expr *team)
+{
+  if (!type_check (image, 1, BT_INTEGER))
+    return false;
+
+  int i = gfc_validate_kind (BT_INTEGER, image->ts.kind, false);
+  int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+  if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+    {
+      gfc_error ("IMAGE argument of the IMAGE_STATUS intrinsic function at %L "
+		 "shall have at least the range of the default integer",
+		 &image->where);
+      return false;
+    }
+
+  j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind*2, false);
+
+  if (gfc_integer_kinds[i].range > gfc_integer_kinds[j].range)
+    {
+      gfc_error ("IMAGE argument of the IMAGE_STATUS intrinsic function at %L "
+		 "shall have at most the range of the double precision integer",
+		 &image->where);
+      return false;
+    }
+
+  if (team)
+    {
+      gfc_error ("TEAM argument of the IMAGE_STATUS intrinsic function at %L "
+		 "not yet supported",
+		 &team->where);
+      return false;
+    }
+
+  return true;
+}
+
+bool
+gfc_check_failed_images (gfc_expr *team, gfc_expr *kind)
+{
+  if (team)
+    {
+      gfc_error ("TEAM argument of the FAILED_IMAGES intrinsic function "
+		 "at %L not yet supported", &team->where);
+      return false;
+    }
+
+  if (kind)
+    {
+      int i = gfc_validate_kind (BT_INTEGER, kind->ts.kind, false);
+      int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
+
+      if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
+	{
+	  gfc_error ("KIND argument of the FAILED_IMAGES intrinsic function "
+		     "at %L shall have at least the range "
+		     "of the default integer", &kind->where);
+	  return false;
+	}
+
+      j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind*2, false);
+
+      if (gfc_integer_kinds[i].range > gfc_integer_kinds[j].range)
+	{
+	  gfc_error ("KIND argument of the FAILED_IMAGES "
+		     "intrinsic function at %L shall have at most the "
+		     "range of the double precision integer",
+		     &kind->where);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
 
 bool
 gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 8c24074..e731916 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1636,6 +1636,9 @@  show_code_node (int level, gfc_code *c)
 
       break;
 
+    case EXEC_FAIL_IMAGE:
+      fputs ("FAIL IMAGE ", dumpfile);
+
     case EXEC_SYNC_ALL:
       fputs ("SYNC ALL ", dumpfile);
       if (c->expr2 != NULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c3fb6ed..c617340 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -255,7 +255,7 @@  enum gfc_statement
   ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
   ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
   ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
-  ST_EVENT_WAIT,ST_NONE
+  ST_EVENT_WAIT,ST_FAIL_IMAGE,ST_NONE
 };
 
 /* Types of interfaces that we can have.  Assignment interfaces are
@@ -420,6 +420,7 @@  enum gfc_isym_id
   GFC_ISYM_EXP,
   GFC_ISYM_EXPONENT,
   GFC_ISYM_EXTENDS_TYPE_OF,
+  GFC_ISYM_FAILED_IMAGES,
   GFC_ISYM_FDATE,
   GFC_ISYM_FE_RUNTIME_ERROR,
   GFC_ISYM_FGET,
@@ -463,6 +464,7 @@  enum gfc_isym_id
   GFC_ISYM_IEOR,
   GFC_ISYM_IERRNO,
   GFC_ISYM_IMAGE_INDEX,
+  GFC_ISYM_IMAGE_STATUS,
   GFC_ISYM_INDEX,
   GFC_ISYM_INT,
   GFC_ISYM_INT2,
@@ -2395,7 +2397,7 @@  enum gfc_exec_op
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
   EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
   EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
-  EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
+  EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, EXEC_FAIL_IMAGE,
   EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE,
   EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
   EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index cad54b8..ac0dd5e 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1840,6 +1840,12 @@  add_functions (void)
 	     a, BT_UNKNOWN, 0, REQUIRED,
 	     mo, BT_UNKNOWN, 0, REQUIRED);
 
+  add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL,
+	     ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
+	     gfc_check_failed_images, gfc_simplify_failed_images,
+	     gfc_resolve_failed_images, "team", BT_INTEGER, di, OPTIONAL,
+	     "kind", BT_INTEGER, di, OPTIONAL);
+
   add_sym_0 ("fdate",  GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
 	     dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
 
@@ -2081,6 +2087,11 @@  add_functions (void)
 	     gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
 	     ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
 
+  add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008_TS, gfc_check_image_status,
+	     gfc_simplify_image_status, gfc_resolve_image_status, "image",
+	     BT_INTEGER, di, REQUIRED, "team", BT_INTEGER, di, OPTIONAL);
+
   /* The resolution function for INDEX is called gfc_resolve_index_func
      because the name gfc_resolve_index is already used in resolve.c.  */
   add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index f228976..ae488e8 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -71,6 +71,7 @@  bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_dtime_etime (gfc_expr *);
 bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_failed_images (gfc_expr *, gfc_expr *);
 bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
 bool gfc_check_fgetput (gfc_expr *);
 bool gfc_check_float (gfc_expr *);
@@ -92,6 +93,7 @@  bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
 bool gfc_check_idnint (gfc_expr *);
 bool gfc_check_ieor (gfc_expr *, gfc_expr *);
+bool gfc_check_image_status (gfc_expr *, gfc_expr *);
 bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_int (gfc_expr *, gfc_expr *);
 bool gfc_check_intconv (gfc_expr *);
@@ -289,6 +291,7 @@  gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
 gfc_expr *gfc_simplify_exp (gfc_expr *);
 gfc_expr *gfc_simplify_exponent (gfc_expr *);
 gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_failed_images (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_float (gfc_expr *);
 gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_fraction (gfc_expr *);
@@ -305,6 +308,7 @@  gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_int2 (gfc_expr *);
@@ -467,6 +471,7 @@  void gfc_resolve_event_query (gfc_code *);
 void gfc_resolve_exp (gfc_expr *, gfc_expr *);
 void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
 void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_failed_images (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fdate (gfc_expr *);
 void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
@@ -490,6 +495,7 @@  void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 			     gfc_expr *);
 void gfc_resolve_ierrno (gfc_expr *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index ecea1c3..dc05cd3 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2577,6 +2577,30 @@  gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
     = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind);
 }
 
+void
+gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
+			   gfc_expr *kind)
+{
+  static char failed_images[] = "_gfortran_caf_failed_images";
+  f->rank = 1;
+  f->ts.type = BT_INTEGER;
+  if (kind == NULL)
+    f->ts.kind = gfc_default_integer_kind;
+  else
+    f->ts.kind = kind->ts.kind;
+  f->value.function.name = failed_images;
+}
+
+void
+gfc_resolve_image_status (gfc_expr *f, gfc_expr *image,
+			  gfc_expr *team ATTRIBUTE_UNUSED)
+{
+  static char image_status[] = "_gfortran_caf_image_status";
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_kind;
+  f->ts = image->ts;
+  f->value.function.name = image_status;
+}
 
 void
 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index e913250..f00ed83 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -123,7 +123,7 @@  typedef enum
   GFC_STAT_LOCKED,
   GFC_STAT_LOCKED_OTHER_IMAGE,
   GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
-  GFC_STAT_FAILED_IMAGE
+  GFC_STAT_FAILED_IMAGE = 6001
 }
 libgfortran_stat_codes;
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 9056cb7..8916767 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1600,6 +1600,7 @@  gfc_match_if (gfc_statement *if_type)
   match ("event post", gfc_match_event_post, ST_EVENT_POST)
   match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
   match ("exit", gfc_match_exit, ST_EXIT)
+  match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
   match ("flush", gfc_match_flush, ST_FLUSH)
   match ("forall", match_simple_forall, ST_FORALL)
   match ("go to", gfc_match_goto, ST_GOTO)
@@ -3079,6 +3080,34 @@  gfc_match_event_wait (void)
   return event_statement (ST_EVENT_WAIT);
 }
 
+/* Match a FAIL IMAGE statement.  */
+
+static match
+fail_image_statement (gfc_statement st)
+{
+  if (gfc_match_char ('(') == MATCH_YES)
+    goto syntax;
+
+  gcc_assert (st == ST_FAIL_IMAGE);
+
+  new_st.op = EXEC_FAIL_IMAGE;
+
+  return MATCH_YES;
+
+ syntax:
+  gfc_syntax_error (st);
+
+  return MATCH_ERROR;
+}
+
+match
+gfc_match_fail_image (void)
+{
+  if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C"))
+    return MATCH_ERROR;
+
+  return fail_image_statement (ST_FAIL_IMAGE);
+}
 
 /* Match LOCK/UNLOCK statement. Syntax:
      LOCK ( lock-variable [ , lock-stat-list ] )
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 348ca70..4e4b833 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -72,6 +72,7 @@  match gfc_match_else (void);
 match gfc_match_elseif (void);
 match gfc_match_event_post (void);
 match gfc_match_event_wait (void);
+match gfc_match_fail_image (void);
 match gfc_match_critical (void);
 match gfc_match_block (void);
 match gfc_match_associate (void);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index d78a2c0..3722075 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -483,6 +483,7 @@  decode_statement (void)
       break;
 
     case 'f':
+      match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
       match ("final", gfc_match_final_decl, ST_FINAL);
       match ("flush", gfc_match_flush, ST_FLUSH);
       match ("format", gfc_match_format, ST_FORMAT);
@@ -1419,7 +1420,7 @@  next_statement (void)
   case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
   case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
   case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
-  case ST_EVENT_POST: case ST_EVENT_WAIT: \
+  case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
   case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
   case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
 
@@ -1745,6 +1746,9 @@  gfc_ascii_statement (gfc_statement st)
     case ST_EVENT_WAIT:
       p = "EVENT WAIT";
       break;
+    case ST_FAIL_IMAGE:
+      p = "FAIL IMAGE";
+      break;
     case ST_END_ASSOCIATE:
       p = "END ASSOCIATE";
       break;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 11b6a14..57c759a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8859,6 +8859,11 @@  find_reachable_labels (gfc_code *block)
     }
 }
 
+static void
+resolve_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
+{
+  return;
+}
 
 static void
 resolve_lock_unlock_event (gfc_code *code)
@@ -10607,6 +10612,10 @@  start:
 	  resolve_lock_unlock_event (code);
 	  break;
 
+	case EXEC_FAIL_IMAGE:
+	  resolve_fail_image (code);
+	  break;
+
 	case EXEC_ENTRY:
 	  /* Keep track of which entry we are up to.  */
 	  current_entry_id = code->ext.entry->id;
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index ad547a1..5e55f02 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2312,6 +2312,26 @@  gfc_simplify_exponent (gfc_expr *x)
   return range_check (result, "EXPONENT");
 }
 
+gfc_expr *
+gfc_simplify_failed_images (gfc_expr *team ATTRIBUTE_UNUSED, gfc_expr *kind)
+{
+  gfc_expr *result;
+  int actual_kind;
+
+  if (flag_coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
+  if (!kind)
+    actual_kind = gfc_default_integer_kind;
+  else
+    actual_kind = kind->ts.kind;
+
+  result = transformational_result (result, NULL, BT_INTEGER, actual_kind,
+				    &gfc_current_locus);
+  init_result_expr (result, 0, NULL);
+  result = simplify_transformation (result, NULL, NULL, 0, NULL);
+  return result;
+}
 
 gfc_expr *
 gfc_simplify_float (gfc_expr *a)
@@ -6578,6 +6598,20 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
   return result;
 }
 
+gfc_expr *
+gfc_simplify_image_status (gfc_expr *image ATTRIBUTE_UNUSED,
+			   gfc_expr *team ATTRIBUTE_UNUSED)
+{
+  if (flag_coarray != GFC_FCOARRAY_SINGLE)
+    return NULL;
+
+  gfc_expr *result;
+  /* FIXME: gfc_current_locus is wrong.  */
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &gfc_current_locus);
+  mpz_set_si (result->value.integer, 0);
+  return result;
+}
 
 gfc_expr *
 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 7395497..b3a6721 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -120,6 +120,7 @@  gfc_free_statement (gfc_code *p)
     case EXEC_UNLOCK:
     case EXEC_EVENT_POST:
     case EXEC_EVENT_WAIT:
+    case EXEC_FAIL_IMAGE:
       break;
 
     case EXEC_BLOCK:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 1bab5d5..ed9f89f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -154,6 +154,9 @@  tree gfor_fndecl_caf_unlock;
 tree gfor_fndecl_caf_event_post;
 tree gfor_fndecl_caf_event_wait;
 tree gfor_fndecl_caf_event_query;
+tree gfor_fndecl_caf_fail_image;
+tree gfor_fndecl_caf_failed_images;
+tree gfor_fndecl_caf_image_status;
 tree gfor_fndecl_co_broadcast;
 tree gfor_fndecl_co_max;
 tree gfor_fndecl_co_min;
@@ -3694,6 +3697,18 @@  gfc_build_builtin_function_decls (void)
 	void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
 	pint_type, pint_type);
 
+      gfor_fndecl_caf_fail_image = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_fail_image")), "R",
+      	void_type_node, 1, pvoid_type_node);
+
+      gfor_fndecl_caf_failed_images = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_failed_images")), "WRR", pvoid_type_node,
+	3, pvoid_type_node, integer_type_node, integer_type_node);
+
+      gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_image_status")), "RR",
+	integer_type_node, 2, integer_type_node, integer_type_node);
+
       gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
 	void_type_node, 5, pvoid_type_node, integer_type_node,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9fcd6a1..5aadc6c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6239,10 +6239,11 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          components must have the result allocatable components copied.  */
       arg = expr->value.function.actual;
       if (result && arg && expr->rank
-	    && expr->value.function.isym
-	    && expr->value.function.isym->transformational
-	    && arg->expr->ts.type == BT_DERIVED
-	    && arg->expr->ts.u.derived->attr.alloc_comp)
+	  && expr->value.function.isym
+	  && expr->value.function.isym->transformational
+	  && arg->expr
+	  && arg->expr->ts.type == BT_DERIVED
+	  && arg->expr->ts.u.derived->attr.alloc_comp)
 	{
 	  tree tmp2;
 	  /* Copy the allocatable components.  We have to use a
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c6883dc..b0b721f 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2360,6 +2360,19 @@  trans_this_image (gfc_se * se, gfc_expr *expr)
 					       m, lbound));
 }
 
+static void
+gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
+{
+  unsigned int num_args;
+  tree *args,tmp;
+
+  num_args = gfc_intrinsic_argument_list_length (expr);
+  args = XALLOCAVEC (tree, num_args);
+  gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
+			     args[0], build_int_cst (integer_type_node, -1));
+  se->expr = tmp;
+}
 
 static void
 trans_image_index (gfc_se * se, gfc_expr *expr)
@@ -9017,6 +9030,10 @@  gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       trans_image_index (se, expr);
       break;
 
+    case GFC_ISYM_IMAGE_STATUS:
+      gfc_conv_intrinsic_image_status (se, expr);
+      break;
+
     case GFC_ISYM_NUM_IMAGES:
       trans_num_images (se, expr);
       break;
@@ -9367,10 +9384,11 @@  gfc_is_intrinsic_libcall (gfc_expr * expr)
       /* Ignore absent optional parameters.  */
       return 1;
 
-    case GFC_ISYM_RESHAPE:
     case GFC_ISYM_CSHIFT:
     case GFC_ISYM_EOSHIFT:
+    case GFC_ISYM_FAILED_IMAGES:
     case GFC_ISYM_PACK:
+    case GFC_ISYM_RESHAPE:
     case GFC_ISYM_UNPACK:
       /* Pass absent optional parameters.  */
       return 2;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 9fdacc1..22c37ee 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -674,6 +674,32 @@  gfc_trans_stop (gfc_code *code, bool error_stop)
   return gfc_finish_block (&se.pre);
 }
 
+/* Translate the FAIL IMAGE statement.  We have to translate this statement
+   to a runtime library call.  */
+
+tree
+gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
+{
+  gfc_se se;
+  tree tmp;
+
+  /* Start a new block for this statement.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  if (flag_coarray == GFC_FCOARRAY_LIB)
+    tmp = build_call_expr_loc (input_location,
+			       gfor_fndecl_caf_fail_image, 1,
+			       build_int_cst (pchar_type_node, 0));
+  else
+    tmp = build_call_expr_loc (input_location,
+			       gfor_fndecl_stop_string, 1,
+			       build_int_cst (pchar_type_node, 1));
+
+  gfc_add_expr_to_block (&se.pre, tmp);
+  gfc_add_block_to_block (&se.pre, &se.post);
+  return gfc_finish_block (&se.pre);
+}
 
 tree
 gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index f9c8e74..4b5b4fc 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -56,6 +56,7 @@  tree gfc_trans_select (gfc_code *);
 tree gfc_trans_sync (gfc_code *, gfc_exec_op);
 tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
 tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
+tree gfc_trans_fail_image (gfc_code *);
 tree gfc_trans_forall (gfc_code *);
 tree gfc_trans_where (gfc_code *);
 tree gfc_trans_allocate (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 9210e0f..827e0bf 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1858,6 +1858,10 @@  trans_code (gfc_code * code, tree cond)
 	  res = gfc_trans_event_post_wait (code, code->op);
 	  break;
 
+	case EXEC_FAIL_IMAGE:
+	  res = gfc_trans_fail_image (code);
+	  break;
+
 	case EXEC_FORALL:
 	  res = gfc_trans_forall (code);
 	  break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4d3d207..4641ace 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -800,6 +800,9 @@  extern GTY(()) tree gfor_fndecl_caf_unlock;
 extern GTY(()) tree gfor_fndecl_caf_event_post;
 extern GTY(()) tree gfor_fndecl_caf_event_wait;
 extern GTY(()) tree gfor_fndecl_caf_event_query;
+extern GTY(()) tree gfor_fndecl_caf_fail_image;
+extern GTY(()) tree gfor_fndecl_caf_failed_images;
+extern GTY(()) tree gfor_fndecl_caf_image_status;
 extern GTY(()) tree gfor_fndecl_co_broadcast;
 extern GTY(()) tree gfor_fndecl_co_max;
 extern GTY(()) tree gfor_fndecl_co_min;
diff --git a/gcc/testsuite/gfortran.dg/coarray/fail_st.f90 b/gcc/testsuite/gfortran.dg/coarray/fail_st.f90
new file mode 100644
index 0000000..b6e50e0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/fail_st.f90
@@ -0,0 +1,9 @@ 
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+program fail_statement
+  implicit none
+
+  fail image
+
+end program fail_statement
diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90 b/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90
new file mode 100644
index 0000000..5583fef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_single.f90
@@ -0,0 +1,15 @@ 
+! { dg-do run }
+! { dg-options "-fcoarray=single -lcaf_single" }
+!
+program test_failed_images
+  use iso_fortran_env
+  implicit none
+
+  integer, allocatable :: failed(:)
+
+  failed = failed_images()
+
+  write(*,*) failed,lbound(failed),ubound(failed)
+  write(*,*) failed_images()
+
+end program test_failed_images
diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90 b/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90
new file mode 100644
index 0000000..71d58b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/image_status_single.f90
@@ -0,0 +1,9 @@ 
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+program test_image_status
+  implicit none
+
+  write(*,*) image_status(1)
+
+end program test_image_status
diff --git a/gcc/testsuite/gfortran.dg/coarray_fail_st.f90 b/gcc/testsuite/gfortran.dg/coarray_fail_st.f90
new file mode 100644
index 0000000..d4eb8e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_fail_st.f90
@@ -0,0 +1,21 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+program fail_statement
+  implicit none
+
+  integer :: me,np,stat
+
+  me = this_image()
+  np = num_images()
+  stat = 0
+
+  if(me == 1) fail image
+
+  sync all(stat=stat)
+
+  if(stat /= 0) write(*,*) 'Image failed during sync'
+
+end program fail_statement
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_fail_image \\\(0B\\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_failed_images.f90 b/gcc/testsuite/gfortran.dg/coarray_failed_images.f90
new file mode 100644
index 0000000..b64ed25
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_failed_images.f90
@@ -0,0 +1,21 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+program test_failed_images
+  implicit none
+
+  integer :: me,np,stat
+  character(len=1) :: c
+
+  me = this_image()
+  np = num_images()
+  stat = 0
+
+  sync all(stat=stat)
+
+  if(stat /= 0) then
+     write(*,*) failed_images()
+  endif
+end program test_failed_images
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&atmp.1, 0B, 0B\\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90 b/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90
new file mode 100644
index 0000000..c3b1a79
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_failed_images_err.f90
@@ -0,0 +1,19 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+program test_failed_images_err
+  implicit none
+
+  integer :: me,np,stat
+  character(len=1) :: c
+
+  me = this_image()
+  np = num_images()
+  stat = 0
+
+  sync all(stat=stat)
+
+  if(stat /= 0) then
+     write(*,*) failed_images(me) ! { dg-error "TEAM argument of the FAILED_IMAGES intrinsic function at .1. not yet supported" }
+  endif
+end program test_failed_images_err
diff --git a/gcc/testsuite/gfortran.dg/coarray_image_status.f90 b/gcc/testsuite/gfortran.dg/coarray_image_status.f90
new file mode 100644
index 0000000..9145da7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_image_status.f90
@@ -0,0 +1,21 @@ 
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+program test_image_status
+  implicit none
+
+  integer :: me,np,stat
+  character(len=1) :: c
+
+  me = this_image()
+  np = num_images()
+  stat = 0
+
+  sync all(stat=stat)
+
+  if(stat /= 0) then
+     write(*,*) image_status(1)
+  endif
+end program test_image_status
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(1, -1\\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90 b/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90
new file mode 100644
index 0000000..bf36f59
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_image_status_err.f90
@@ -0,0 +1,19 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+program test_image_status_err
+  implicit none
+
+  integer :: me,np,stat
+  character(len=1) :: c
+
+  me = this_image()
+  np = num_images()
+  stat = 0
+
+  sync all(stat=stat)
+
+  if(stat /= 0) then
+     write(*,*) image_status(1,team=1) ! { dg-error "TEAM argument of the IMAGE_STATUS intrinsic function at .1. not yet supported" }
+  endif
+end program test_image_status_err
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index aad0f62..8e10ba6 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -231,5 +231,7 @@  void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
 void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
 void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
 void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
-
+void _gfortran_caf_failed_images(gfc_descriptor_t *,
+				 int __attribute__ ((unused)),
+				 int __attribute__ ((unused)));
 #endif  /* LIBCAF_H  */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index c472446..72e4672 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -2877,3 +2877,17 @@  _gfortran_caf_unlock (caf_token_t token, size_t index,
     }
   _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
 }
+
+void
+_gfortran_caf_failed_images(gfc_descriptor_t *array,
+			    int team __attribute__ ((unused)),
+			    int kind __attribute__ ((unused)))
+{
+  int *mem = (int *)calloc(1,sizeof(int));
+  array->base_addr = mem;
+  array->dtype = 265;
+  array->dim[0].lower_bound = 0;
+  array->dim[0]._ubound = -1;
+  array->dim[0]._stride = 1;
+  array->offset = -1;
+}