[Fortran] Help with intrinsic function returning array

[Fortran] Help with intrinsic function returning array

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 1296 bytes --]

Dear all,

I'm encountering some difficulties with implementing the intrinsic
function "failed_images" defined in the latest TS-18508
(http://isotc.iso.org/livelink/livelink?func=ll&objId=17288706&objAction=Open).

The idea is to call the external _gfortran_caf_failed_images function
(implemented in OpenCoarrays) than returns a rank-1 integer array
representing the list of coarray images that have been failed
(detected by the calling images).
Of course, the number of failed images is not known a-priori by the
user, thus the list should be stored in an allocatable array.

So far, I pass by reference the variable representing the list length
to the _gfortran_caf_failed_images function; once returned, this value
contains the number of elements composing the array.
Then, I manually build a temporary array, setting the right
bounds,type,data and offset.

What I would like to do is to assign this temporary array to the
variable on the lhs of the assignment.

I noticed several routines that manage the situation of a function
returning an array but it is not clear to me how to adapt them to my
situation.

In attachment you can find what I've done so far; the function that
I'm referring to is gfc_conv_intrinsic_failed_images.

Thanks in advance for your support.

Regards,

Alessandro

[-- Attachment #2: third_patch.diff --]
[-- Type: text/plain, Size: 21180 bytes --]

commit b909d0508434b9b9479fd3fd18fc6110d35d0c11
Author: Alessandro Fanfarillo <fanfarillo@ing.uniroma2.it>
Date:   Tue May 3 11:46:03 2016 -0600

    Third patch

diff --git ./gcc/fortran/check.c ./gcc/fortran/check.c
index 05133c32..680090c 100644
--- ./gcc/fortran/check.c
+++ ./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 ./gcc/fortran/dump-parse-tree.c ./gcc/fortran/dump-parse-tree.c
index 8d50d75..3a8769c 100644
--- ./gcc/fortran/dump-parse-tree.c
+++ ./gcc/fortran/dump-parse-tree.c
@@ -1627,6 +1627,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 ./gcc/fortran/gfortran.h ./gcc/fortran/gfortran.h
index a0fb5fd..569a564 100644
--- ./gcc/fortran/gfortran.h
+++ ./gcc/fortran/gfortran.h
@@ -242,7 +242,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
@@ -400,6 +400,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,
@@ -443,6 +444,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,
@@ -2371,7 +2373,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 ./gcc/fortran/intrinsic.c ./gcc/fortran/intrinsic.c
index 1d7503d..8dfb568 100644
--- ./gcc/fortran/intrinsic.c
+++ ./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 ./gcc/fortran/intrinsic.h ./gcc/fortran/intrinsic.h
index f228976..bb49b7d 100644
--- ./gcc/fortran/intrinsic.h
+++ ./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 ./gcc/fortran/iresolve.c ./gcc/fortran/iresolve.c
index ecea1c3..d338e5b 100644
--- ./gcc/fortran/iresolve.c
+++ ./gcc/fortran/iresolve.c
@@ -2577,6 +2577,25 @@ 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[] = "failed_images";
+  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 ./gcc/fortran/match.c ./gcc/fortran/match.c
index 2490f85..20aa371 100644
--- ./gcc/fortran/match.c
+++ ./gcc/fortran/match.c
@@ -1472,6 +1472,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)
@@ -2951,6 +2952,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 ./gcc/fortran/match.h ./gcc/fortran/match.h
index c3033ad..9497f4e 100644
--- ./gcc/fortran/match.h
+++ ./gcc/fortran/match.h
@@ -71,6 +71,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 ./gcc/fortran/parse.c ./gcc/fortran/parse.c
index 7bce47f..99ebc07 100644
--- ./gcc/fortran/parse.c
+++ ./gcc/fortran/parse.c
@@ -482,6 +482,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);
@@ -1350,7 +1351,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
 
@@ -1663,6 +1664,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 ./gcc/fortran/resolve.c ./gcc/fortran/resolve.c
index f5cd588..4509da0 100644
--- ./gcc/fortran/resolve.c
+++ ./gcc/fortran/resolve.c
@@ -8743,6 +8743,11 @@ find_reachable_labels (gfc_code *block)
     }
 }
 
+static void
+resolve_fail_image (gfc_code *code)
+{
+  return;
+}
 
 static void
 resolve_lock_unlock_event (gfc_code *code)
@@ -10473,6 +10478,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 ./gcc/fortran/st.c ./gcc/fortran/st.c
index 7395497..b3a6721 100644
--- ./gcc/fortran/st.c
+++ ./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 ./gcc/fortran/trans-decl.c ./gcc/fortran/trans-decl.c
index 309baf1..f9c76aa 100644
--- ./gcc/fortran/trans-decl.c
+++ ./gcc/fortran/trans-decl.c
@@ -150,6 +150,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;
@@ -3611,6 +3614,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 ./gcc/fortran/trans-intrinsic.c ./gcc/fortran/trans-intrinsic.c
index 1aaf4e2..e37c938 100644
--- ./gcc/fortran/trans-intrinsic.c
+++ ./gcc/fortran/trans-intrinsic.c
@@ -1647,6 +1647,113 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
 					       m, lbound));
 }
 
+static void
+gfc_conv_intrinsic_failed_images (gfc_se *se, gfc_expr *expr)
+{
+  tree tmp,type,res_var,size_var,desc,offset,ubound,stride;
+  stmtblock_t temp_post;
+  gfc_se argse, loopse;
+  gfc_loopinfo loop;
+  gfc_expr array_expr;
+  gfc_ss *tmp_ss;
+  tree parm, parmtype;
+  gfc_array_info *info;
+
+  /* If mem is NULL, we call gfc_allocate_using_malloc or
+     gfc_allocate_using_lib.  */
+  
+  size_var = gfc_create_var (gfc_array_index_type, "arr");
+  /* res_var = gfc_create_var (pvoid_type_node, "res"); */
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (flag_coarray == GFC_FCOARRAY_LIB)
+    { 
+      res_var = build_call_expr_loc (input_location, gfor_fndecl_caf_failed_images, 3,
+				 gfc_build_addr_expr (build_pointer_type (type), size_var),
+				 build_int_cst (integer_type_node, -1),
+  				 build_int_cst (integer_type_node, -1));
+
+      /* se->expr = res_var; */
+      
+      loop.ss = gfc_get_array_ss (gfc_ss_terminator, NULL, 1,
+				  GFC_SS_SECTION);
+      tmp_ss = gfc_walk_expr (expr);
+
+      loop.ss->info->type = GFC_SS_SECTION;
+
+      gfc_init_loopinfo (&loop);
+      gfc_add_ss_to_loop (&loop, tmp_ss);
+      loop.dimen = 1;
+      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			     gfc_array_index_type, gfc_index_one_node,
+			     gfc_index_one_node);
+      
+      loop.to[0] = fold_build2_loc (input_location, PLUS_EXPR,
+				    gfc_array_index_type,
+				    size_var, tmp);
+      loop.from[0] = gfc_index_one_node;
+      
+      /* parmtype = gfc_get_element_type (integer_type_node); */
+      parmtype = type;
+      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+					    loop.from, loop.to, 0,
+					    GFC_ARRAY_UNKNOWN, false);
+      parm = gfc_create_var (parmtype, "parm");
+      tmp = gfc_conv_descriptor_dtype (parm);
+      gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+
+      gfc_conv_descriptor_data_set (&loop.pre, parm, res_var);
+      
+      tmp = gfc_conv_array_lbound (parm, 0);
+      
+      gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_index_zero_node, tmp);
+
+      ubound = gfc_conv_array_ubound (parm, 0);
+      
+      gfc_conv_descriptor_ubound_set (&loop.pre, parm, gfc_index_zero_node, size_var);
+
+      stride = gfc_conv_array_stride (parm, 0);
+
+      gfc_conv_descriptor_stride_set (&loop.pre, parm, gfc_index_zero_node, gfc_index_one_node);
+      
+      /* tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), */
+      /* 			     gfc_index_zero_node, tmp); */
+      /* tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), */
+      /* 			     tmp, gfc_index_one_node); */
+      /* offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), */
+      /* 				gfc_index_zero_node, tmp); */
+      
+      offset = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+				gfc_index_zero_node, tmp);
+      
+      gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
+
+      se->expr = gfc_conv_descriptor_data_get (parm);
+
+      gfc_add_block_to_block (&se->pre, &loop.pre);
+      gfc_add_block_to_block (&se->post, &loop.post);
+    }
+  /* tmp = gfc_finish_block (&alloc_block); */
+}
+
+static void
+gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
+{
+  unsigned int num_args;
+  tree *args,tmp,rettype,res;
+  
+  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)
@@ -8299,10 +8406,18 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	trans_this_image (se, expr);
       break;
 
+    case GFC_ISYM_FAILED_IMAGES:
+      gfc_conv_intrinsic_failed_images (se, expr);
+      break;
+
     case GFC_ISYM_IMAGE_INDEX:
       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;
diff --git ./gcc/fortran/trans-stmt.c ./gcc/fortran/trans-stmt.c
index 2fc43ed..76e3135 100644
--- ./gcc/fortran/trans-stmt.c
+++ ./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)
+{
+  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 ./gcc/fortran/trans-stmt.h ./gcc/fortran/trans-stmt.h
index f9c8e74..4b5b4fc 100644
--- ./gcc/fortran/trans-stmt.h
+++ ./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 ./gcc/fortran/trans.c ./gcc/fortran/trans.c
index c6688d3..db0aa49 100644
--- ./gcc/fortran/trans.c
+++ ./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 ./gcc/fortran/trans.h ./gcc/fortran/trans.h
index 512615a..c6b142f 100644
--- ./gcc/fortran/trans.h
+++ ./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;

Re: [Fortran] Help with intrinsic function returning array

[Mikael Morin]

Le 11/05/2016 23:35, Alessandro Fanfarillo a écrit :
> Dear all,
>
> I'm encountering some difficulties with implementing the intrinsic
> function "failed_images" defined in the latest TS-18508
> (http://isotc.iso.org/livelink/livelink?func=ll&objId=17288706&objAction=Open).
>
> The idea is to call the external _gfortran_caf_failed_images function
> (implemented in OpenCoarrays) than returns a rank-1 integer array
> representing the list of coarray images that have been failed
> (detected by the calling images).
> Of course, the number of failed images is not known a-priori by the
> user, thus the list should be stored in an allocatable array.
>
> So far, I pass by reference the variable representing the list length
> to the _gfortran_caf_failed_images function; once returned, this value
> contains the number of elements composing the array.
> Then, I manually build a temporary array, setting the right
> bounds,type,data and offset.
>
> What I would like to do is to assign this temporary array to the
> variable on the lhs of the assignment.
>
> I noticed several routines that manage the situation of a function
> returning an array but it is not clear to me how to adapt them to my
> situation.
>
> In attachment you can find what I've done so far; the function that
> I'm referring to is gfc_conv_intrinsic_failed_images.
>
> Thanks in advance for your support.
>
> Regards,
>
> Alessandro
>
Hello,

is there something preventing you from passing the variable's array 
descriptor address directly to the function, so that it's already all 
setup and assigned upon return?
I think that would be the easiest. Namely add the GFC_ISYM_FAILED_IMAGES 
to gfc_is_intrinsic_libcall, and see whether it works automatically (no 
promise).

Mikael

Re: [Fortran] Help with intrinsic function returning array

[Alessandro Fanfarillo]

Hi,

actually I've already tried that way but the size of the array
returned by the function cannot be computed by the compiler. The
number of failed images is an information contained in OpenCoarrays
(which is an external library).

Here is an example:

program fail
integer, allocatable :: failed(:)

failed = failed_images()

end program

In this case I expect to see the assignment translated into something like:

failed.data = _gfortran_caf_failed_images(&size,0B,0B);
failed.offset = -1;
failed.dim[0].lbound = 1;
failed.dim[0].ubound = size;



2016-05-16 14:06 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:
> Le 11/05/2016 23:35, Alessandro Fanfarillo a écrit :
>>
>> Dear all,
>>
>> I'm encountering some difficulties with implementing the intrinsic
>> function "failed_images" defined in the latest TS-18508
>>
>> (http://isotc.iso.org/livelink/livelink?func=ll&objId=17288706&objAction=Open).
>>
>> The idea is to call the external _gfortran_caf_failed_images function
>> (implemented in OpenCoarrays) than returns a rank-1 integer array
>> representing the list of coarray images that have been failed
>> (detected by the calling images).
>> Of course, the number of failed images is not known a-priori by the
>> user, thus the list should be stored in an allocatable array.
>>
>> So far, I pass by reference the variable representing the list length
>> to the _gfortran_caf_failed_images function; once returned, this value
>> contains the number of elements composing the array.
>> Then, I manually build a temporary array, setting the right
>> bounds,type,data and offset.
>>
>> What I would like to do is to assign this temporary array to the
>> variable on the lhs of the assignment.
>>
>> I noticed several routines that manage the situation of a function
>> returning an array but it is not clear to me how to adapt them to my
>> situation.
>>
>> In attachment you can find what I've done so far; the function that
>> I'm referring to is gfc_conv_intrinsic_failed_images.
>>
>> Thanks in advance for your support.
>>
>> Regards,
>>
>> Alessandro
>>
> Hello,
>
> is there something preventing you from passing the variable's array
> descriptor address directly to the function, so that it's already all setup
> and assigned upon return?
> I think that would be the easiest. Namely add the GFC_ISYM_FAILED_IMAGES to
> gfc_is_intrinsic_libcall, and see whether it works automatically (no
> promise).
>
> Mikael
>

Re: [Fortran] Help with intrinsic function returning array

[Mikael Morin]

Le 17/05/2016 05:30, Alessandro Fanfarillo a écrit :
> Hi,
>
> actually I've already tried that way but the size of the array
> returned by the function cannot be computed by the compiler. The
> number of failed images is an information contained in OpenCoarrays
> (which is an external library).
>
> Here is an example:
>
> program fail
> integer, allocatable :: failed(:)
>
> failed = failed_images()
>
> end program
>
> In this case I expect to see the assignment translated into something like:
>
> failed.data = _gfortran_caf_failed_images(&size,0B,0B);
> failed.offset = -1;
> failed.dim[0].lbound = 1;
> failed.dim[0].ubound = size;
>
Well, what I was telling was aiming at producing something more like that:
   _gfortran_caf_failed_images(&failed);
It's probably doable that way, but there might be some problems indeed 
with the scalarizer. Most existing intrinsics functions calling the 
library can have their result shape inferred before the call.


Now, to do it your way:
As failed_images is  a function, you are supposed to produce an 
expression that gfc_trans_assignment will use. You can't directly assign 
to the lhs, as there may not be an lhs to assign to.
Think of the cases:
   variable = (/ some_data, failed_images(), some_other_data /)
   variable = some_function(failed_images())

the expression is your temporary descriptor, and it should be used after 
it has been initialized by your code.
So set se->expr to parm (the array descriptor), and add all your code 
(the result of gfc_finish_block) to se->pre.

That should be mostly it, but I guess the devil will be in the details.

Mikael

Re: [Fortran] Help with intrinsic function returning array

[Alessandro Fanfarillo]

2016-05-17 13:46 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:

> Well, what I was telling was aiming at producing something more like that:
>   _gfortran_caf_failed_images(&failed);
> It's probably doable that way, but there might be some problems indeed with
> the scalarizer. Most existing intrinsics functions calling the library can
> have their result shape inferred before the call.

I think it would be much more easy to use a subroutine rather than a
function. Is there an easy way to
transform the intrinsic function in a subroutine invocation?

>
>
> Now, to do it your way:
> As failed_images is  a function, you are supposed to produce an expression
> that gfc_trans_assignment will use. You can't directly assign to the lhs, as
> there may not be an lhs to assign to.
> Think of the cases:
>   variable = (/ some_data, failed_images(), some_other_data /)
>   variable = some_function(failed_images())
>
> the expression is your temporary descriptor, and it should be used after it
> has been initialized by your code.
> So set se->expr to parm (the array descriptor), and add all your code (the
> result of gfc_finish_block) to se->pre.
>
> That should be mostly it, but I guess the devil will be in the details.
>
> Mikael
>

Re: [Fortran] Help with intrinsic function returning array

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 984 bytes --]

Le 17/05/2016 22:20, Alessandro Fanfarillo a écrit :
> 2016-05-17 13:46 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:
>
>> Well, what I was telling was aiming at producing something more like that:
>>    _gfortran_caf_failed_images(&failed);
>> It's probably doable that way, but there might be some problems indeed with
>> the scalarizer. Most existing intrinsics functions calling the library can
>> have their result shape inferred before the call.
>
> I think it would be much more easy to use a subroutine rather than a
> function. Is there an easy way to
> transform the intrinsic function in a subroutine invocation?
>
Well, all the infrastructure is already there.
You just need to tell that the function returns a non-scalar result.
I attach an incremental patch, whose result I have only visually inspected.
The code generated is not very neat, and does some strange things, but 
it has the essential parts.
The setting of the bounds probably need more investigation.




[-- Attachment #2: incremental_failed_images.diff --]
[-- Type: text/x-patch, Size: 6137 bytes --]

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index d338e5b..5851815 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2582,6 +2582,7 @@ gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
 			   gfc_expr *kind ATTRIBUTE_UNUSED)
 {
   static char failed_images[] = "failed_images";
+  f->rank = 1;
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = failed_images;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1bea9d6..bbb0abb 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8733,7 +8733,7 @@ find_reachable_labels (gfc_code *block)
 }
 
 static void
-resolve_fail_image (gfc_code *code)
+resolve_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
 {
   return;
 }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c5ae4c5..2444da2 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6095,6 +6095,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (result && arg && expr->rank
 	    && 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)
 	{
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e37c938..b2f5596 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1648,99 +1648,10 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
 }
 
 static void
-gfc_conv_intrinsic_failed_images (gfc_se *se, gfc_expr *expr)
-{
-  tree tmp,type,res_var,size_var,desc,offset,ubound,stride;
-  stmtblock_t temp_post;
-  gfc_se argse, loopse;
-  gfc_loopinfo loop;
-  gfc_expr array_expr;
-  gfc_ss *tmp_ss;
-  tree parm, parmtype;
-  gfc_array_info *info;
-
-  /* If mem is NULL, we call gfc_allocate_using_malloc or
-     gfc_allocate_using_lib.  */
-  
-  size_var = gfc_create_var (gfc_array_index_type, "arr");
-  /* res_var = gfc_create_var (pvoid_type_node, "res"); */
-  type = gfc_typenode_for_spec (&expr->ts);
-
-  if (flag_coarray == GFC_FCOARRAY_LIB)
-    { 
-      res_var = build_call_expr_loc (input_location, gfor_fndecl_caf_failed_images, 3,
-				 gfc_build_addr_expr (build_pointer_type (type), size_var),
-				 build_int_cst (integer_type_node, -1),
-  				 build_int_cst (integer_type_node, -1));
-
-      /* se->expr = res_var; */
-      
-      loop.ss = gfc_get_array_ss (gfc_ss_terminator, NULL, 1,
-				  GFC_SS_SECTION);
-      tmp_ss = gfc_walk_expr (expr);
-
-      loop.ss->info->type = GFC_SS_SECTION;
-
-      gfc_init_loopinfo (&loop);
-      gfc_add_ss_to_loop (&loop, tmp_ss);
-      loop.dimen = 1;
-      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-			     gfc_array_index_type, gfc_index_one_node,
-			     gfc_index_one_node);
-      
-      loop.to[0] = fold_build2_loc (input_location, PLUS_EXPR,
-				    gfc_array_index_type,
-				    size_var, tmp);
-      loop.from[0] = gfc_index_one_node;
-      
-      /* parmtype = gfc_get_element_type (integer_type_node); */
-      parmtype = type;
-      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
-					    loop.from, loop.to, 0,
-					    GFC_ARRAY_UNKNOWN, false);
-      parm = gfc_create_var (parmtype, "parm");
-      tmp = gfc_conv_descriptor_dtype (parm);
-      gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
-
-      gfc_conv_descriptor_data_set (&loop.pre, parm, res_var);
-      
-      tmp = gfc_conv_array_lbound (parm, 0);
-      
-      gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_index_zero_node, tmp);
-
-      ubound = gfc_conv_array_ubound (parm, 0);
-      
-      gfc_conv_descriptor_ubound_set (&loop.pre, parm, gfc_index_zero_node, size_var);
-
-      stride = gfc_conv_array_stride (parm, 0);
-
-      gfc_conv_descriptor_stride_set (&loop.pre, parm, gfc_index_zero_node, gfc_index_one_node);
-      
-      /* tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), */
-      /* 			     gfc_index_zero_node, tmp); */
-      /* tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), */
-      /* 			     tmp, gfc_index_one_node); */
-      /* offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), */
-      /* 				gfc_index_zero_node, tmp); */
-      
-      offset = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
-				gfc_index_zero_node, tmp);
-      
-      gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
-
-      se->expr = gfc_conv_descriptor_data_get (parm);
-
-      gfc_add_block_to_block (&se->pre, &loop.pre);
-      gfc_add_block_to_block (&se->post, &loop.post);
-    }
-  /* tmp = gfc_finish_block (&alloc_block); */
-}
-
-static void
 gfc_conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
 {
   unsigned int num_args;
-  tree *args,tmp,rettype,res;
+  tree *args,tmp;
   
   num_args = gfc_intrinsic_argument_list_length (expr);
   args = XALLOCAVEC (tree, num_args);
@@ -8406,10 +8317,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	trans_this_image (se, expr);
       break;
 
-    case GFC_ISYM_FAILED_IMAGES:
-      gfc_conv_intrinsic_failed_images (se, expr);
-      break;
-
     case GFC_ISYM_IMAGE_INDEX:
       trans_image_index (se, expr);
       break;
@@ -8768,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 2544129..c4070e7 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -672,7 +672,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
    to a runtime library call.  */
 
 tree
-gfc_trans_fail_image (gfc_code *code)
+gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
 {
   tree gfc_int4_type_node = gfc_get_int_type (4);
   gfc_se se;

Re: [Fortran] Help with intrinsic function returning array

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 1522 bytes --]

Thanks! I changed the function name from failed_images to
_gfortran_caf_failed_images and modified OpenCoarrays accordingly.

The attached test case named testFailedImages.f90 works perfectly; the
temporary is recognized by the scalarizer an printed correctly.
On the other hand, the scalarizer doesn't recognize as array an
allocatable array not explicitly allocated (testFailedImages_3.f90).

2016-05-18 14:10 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:
> Le 17/05/2016 22:20, Alessandro Fanfarillo a écrit :
>>
>> 2016-05-17 13:46 GMT-06:00 Mikael Morin <mikael.morin@sfr.fr>:
>>
>>> Well, what I was telling was aiming at producing something more like
>>> that:
>>>    _gfortran_caf_failed_images(&failed);
>>> It's probably doable that way, but there might be some problems indeed
>>> with
>>> the scalarizer. Most existing intrinsics functions calling the library
>>> can
>>> have their result shape inferred before the call.
>>
>>
>> I think it would be much more easy to use a subroutine rather than a
>> function. Is there an easy way to
>> transform the intrinsic function in a subroutine invocation?
>>
> Well, all the infrastructure is already there.
> You just need to tell that the function returns a non-scalar result.
> I attach an incremental patch, whose result I have only visually inspected.
> The code generated is not very neat, and does some strange things, but it
> has the essential parts.
> The setting of the bounds probably need more investigation.
>
>
>

[-- Attachment #2: testFailedImages_3.f90 --]
[-- Type: text/x-fortran, Size: 183 bytes --]

program fail_image
  implicit none
  integer :: fail
  integer, allocatable :: tmp_a(:)
  integer :: me,np,s,tmp

  tmp_a = failed_images()

  write(*,*) tmp_a
end program fail_image

[-- Attachment #3: testFailedImages_3.f90.003t.original --]
[-- Type: application/octet-stream, Size: 1607 bytes --]

fail_image ()
{
  struct array1_integer(kind=4) tmp_a;

  tmp_a.data = 0B;
  {
    integer(kind=8) D.3461;
    integer(kind=8) D.3460;
    logical(kind=4) D.3459;
    logical(kind=4) D.3458;
    logical(kind=4) D.3457;
    struct array1_integer(kind=4) D.3456;

    tmp_a.dtype = 265;
    D.3456 = tmp_a;
    D.3456.data = 0B;
    _gfortran_caf_failed_images (&D.3456, 0B, 0B);
    D.3457 = (integer(kind=4)[0:] * restrict) tmp_a.data == 0B;
    __builtin_free ((void *) tmp_a.data);
    tmp_a.data = D.3456.data;
    D.3458 = ((tmp_a.dim[0].lbound - D.3456.dim[0].lbound) - tmp_a.dim[0].ubound) + D.3456.dim[0].ubound != 0;
    D.3459 = D.3458 || D.3457;
    D.3460 = D.3459 ? 1 : tmp_a.dim[0].lbound;
    tmp_a.dim[0].lbound = D.3460;
    tmp_a.dim[0].ubound = D.3456.dim[0].ubound + D.3460;
    tmp_a.dim[0].stride = 1;
    D.3461 = -NON_LVALUE_EXPR <D.3460>;
    tmp_a.offset = D.3461;
  }
  {
    struct __st_parameter_dt dt_parm.0;

    dt_parm.0.common.filename = &"testFailedImages_3.f90"[1]{lb: 1 sz: 1};
    dt_parm.0.common.line = 9;
    dt_parm.0.common.flags = 128;
    dt_parm.0.common.unit = 6;
    _gfortran_st_write (&dt_parm.0);
    _gfortran_transfer_array_write (&dt_parm.0, &tmp_a, 4, 0);
    _gfortran_st_write_done (&dt_parm.0);
  }
}


__attribute__((externally_visible))
main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.1[9] = {68, 1023, 0, 0, 1, 1, 0, 0, 31};

  _gfortran_caf_init (&argc, &argv);
  _gfortran_set_args (argc, argv);
  _gfortran_set_options (9, &options.1[0]);
  fail_image ();
  _gfortran_caf_finalize ();
  return 0;
}



[-- Attachment #4: testFailedImages.f90 --]
[-- Type: text/x-fortran, Size: 220 bytes --]

program fail_image
  implicit none
  integer :: fail
  integer, dimension(10) :: tmp_a,s_a
  integer :: me,np,s,tmp

  if(this_image() == 1) fail image

  sync all

  write(*,*) failed_images()
  
end program fail_image