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

Alessandro Fanfarillo fanfarillo.gcc@gmail.com
Mon Jun 6 21:05:00 GMT 2016


Dear all,

please find in attachment the first patch (of n) for the FAILED IMAGES
capability defined in the coarray TS 18508.
The patch adds support for three new intrinsic functions defined in
the TS for simulating a failure (fail image), checking an image status
(image_status) and getting the list of failed images (failed_images).
The patch has been built and regtested on x86_64-pc-linux-gnu.

Ok for trunk?

Alessandro
-------------- next part --------------
commit b3bca5b09f4cbcf18f2409dae2485a16a7c06498
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date:   Mon Jun 6 14:27:37 2016 -0600

    First patch Failed Images CAF TS-18508

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index d26e45e..71931cb 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1210,6 +1210,62 @@ 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;
+
+  if(team)
+    {
+      gfc_error ("TEAM argument of the IMAGE_STATUS intrinsic function at %L "
+		 "not yet supported",
+		 &team->where);
+      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;
+    }
+
+  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;
+	}
+    }
+
+  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 f507434..41ed664 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1628,6 +1628,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 0bb71cb..6d87632 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -253,7 +253,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
@@ -411,6 +411,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,
@@ -454,6 +455,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,
@@ -2382,7 +2384,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 1d7503d..8dfb568 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1823,6 +1823,10 @@ 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, NULL,
+	     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);
 
@@ -2023,7 +2027,11 @@ add_functions (void)
   add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
 	     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_YES, BT_INTEGER,
+	     di, GFC_STD_F2008_TS, gfc_check_image_status, NULL,
+	     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,
@@ -3170,7 +3178,7 @@ add_subroutines (void)
 	      "event", BT_INTEGER, di, REQUIRED, INTENT_IN,
 	      c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
 	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
-
+
   /* More G77 compatibility garbage.  */
   add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index f228976..bb49b7d 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 *);
@@ -467,6 +469,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 +493,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..ce59c66 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2577,6 +2577,26 @@ 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 ATTRIBUTE_UNUSED)
+{
+  static char failed_images[] = "_gfortran_caf_failed_images";
+  f->rank = 1;
+  f->ts.type = BT_INTEGER;
+  f->ts.kind = gfc_default_integer_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[] = "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 f3a4a43..9f519ff 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1594,6 +1594,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)
@@ -3073,6 +3074,41 @@ 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 (flag_coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_char ('(') == MATCH_YES)
+    goto syntax;
+
+  if(st == ST_FAIL_IMAGE)
+    new_st.op = EXEC_FAIL_IMAGE;
+  else
+    gcc_unreachable();
+
+  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 1081b2e..3659d8a 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);
@@ -1354,7 +1355,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
 
@@ -1680,6 +1681,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 77f8c10..f56bdf1 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8749,6 +8749,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)
@@ -10479,6 +10484,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/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 2f5e434..7c52744 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -151,6 +151,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;
@@ -3628,6 +3631,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 8f84712..70f9577 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6132,10 +6132,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 1aaf4e2..b2f5596 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1647,6 +1647,24 @@ 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);
+
+  if (flag_coarray == GFC_FCOARRAY_LIB)
+    {
+      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)
@@ -8303,6 +8321,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;
@@ -8653,10 +8675,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 7d3cf8c..ce0eae7 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -674,6 +674,31 @@ 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)
+{
+  tree gfc_int4_type_node = gfc_get_int_type (4);
+  gfc_se se;
+  tree tmp;
+
+  /* Start a new block for this statement.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  tmp = build_int_cst (gfc_int4_type_node, 0);
+  tmp = build_call_expr_loc (input_location,
+			     gfor_fndecl_caf_fail_image, 1,
+			     build_int_cst (pchar_type_node, 0));
+
+  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 c6688d3..db0aa49 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1828,6 +1828,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 512615a..c6b142f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -776,6 +776,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;
-------------- next part --------------
A non-text attachment was scrubbed...
Name: ChangeLog
Type: application/octet-stream
Size: 1475 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/gcc-patches/attachments/20160606/a4e3d799/attachment.obj>


More information about the Gcc-patches mailing list