@@ -1136,6 +1136,116 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
return gfc_check_atomic (atom, 1, value, 0, stat, 2);
}
+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_stopped_images (gfc_expr *team, gfc_expr *kind)
+{
+ if (team)
+ {
+ gfc_error ("TEAM argument of the STOPPED_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 STOPPED_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 STOPPED_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_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
@@ -1818,6 +1818,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)
@@ -263,7 +263,7 @@ enum gfc_statement
ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND,
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
@@ -429,6 +429,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,
@@ -472,6 +473,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,
@@ -585,6 +587,7 @@ enum gfc_isym_id
GFC_ISYM_SRAND,
GFC_ISYM_SR_KIND,
GFC_ISYM_STAT,
+ GFC_ISYM_STOPPED_IMAGES,
GFC_ISYM_STORAGE_SIZE,
GFC_ISYM_STRIDE,
GFC_ISYM_SUM,
@@ -2457,7 +2460,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,
@@ -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,
@@ -2989,6 +3000,12 @@ add_functions (void)
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
+ add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL,
+ ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
+ gfc_check_stopped_images, gfc_simplify_stopped_images,
+ gfc_resolve_stopped_images, "team", BT_INTEGER, di, OPTIONAL,
+ "kind", BT_INTEGER, di, OPTIONAL);
+
add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_storage_size, gfc_simplify_storage_size,
@@ -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 *);
@@ -164,6 +166,7 @@ bool gfc_check_sngl (gfc_expr *);
bool gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_srand (gfc_expr *);
bool gfc_check_stat (gfc_expr *, gfc_expr *);
+bool gfc_check_stopped_images (gfc_expr *, gfc_expr *);
bool gfc_check_storage_size (gfc_expr *, gfc_expr *);
bool gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_symlnk (gfc_expr *, gfc_expr *);
@@ -292,6 +295,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 *);
@@ -308,6 +312,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 *);
@@ -391,6 +396,7 @@ gfc_expr *gfc_simplify_sin (gfc_expr *);
gfc_expr *gfc_simplify_sinh (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sizeof (gfc_expr *);
+gfc_expr *gfc_simplify_stopped_images (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sngl (gfc_expr *);
gfc_expr *gfc_simplify_spacing (gfc_expr *);
@@ -473,6 +479,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 *);
@@ -496,6 +503,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 *);
@@ -571,12 +579,13 @@ void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sin (gfc_expr *, gfc_expr *);
void gfc_resolve_sinh (gfc_expr *, gfc_expr *);
void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
-void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_stopped_images (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind);
+void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_srand (gfc_code *);
void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -2829,6 +2829,29 @@ gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
gfc_resolve_atrigd (f, x);
}
+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,
@@ -2840,6 +2863,19 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
f->value.function.name = image_index;
}
+void
+gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
+ gfc_expr *kind)
+{
+ static char stopped_images[] = "_gfortran_caf_stopped_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 = stopped_images;
+}
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
@@ -124,7 +124,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;
@@ -1601,6 +1601,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)
@@ -3264,6 +3265,33 @@ 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 ] )
@@ -73,6 +73,7 @@ match gfc_match_elseif (void);
match gfc_match_event_post (void);
match gfc_match_event_wait (void);
match gfc_match_critical (void);
+match gfc_match_fail_image (void);
match gfc_match_block (void);
match gfc_match_associate (void);
match gfc_match_do (void);
@@ -488,6 +488,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);
@@ -1499,7 +1500,7 @@ next_statement (void)
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
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
@@ -1827,6 +1828,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;
@@ -9084,6 +9084,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)
@@ -10850,6 +10855,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;
@@ -2464,6 +2464,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)
@@ -2486,6 +2506,26 @@ gfc_simplify_float (gfc_expr *a)
return range_check (result, "FLOAT");
}
+gfc_expr *
+gfc_simplify_stopped_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;
+}
static bool
is_last_ref_vtab (gfc_expr *e)
@@ -6763,6 +6803,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,
@@ -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:
@@ -153,6 +153,10 @@ 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_caf_stopped_images;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@@ -3732,6 +3736,27 @@ 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_caf_stopped_images =
+ gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("caf_stopped_images")), "WRR",
+ pvoid_type_node, 3, pvoid_type_node, 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,
@@ -6231,10 +6231,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
@@ -2387,6 +2387,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)
@@ -9108,6 +9121,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;
@@ -9458,10 +9475,12 @@ 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_STOPPED_IMAGES:
case GFC_ISYM_PACK:
+ case GFC_ISYM_RESHAPE:
case GFC_ISYM_UNPACK:
/* Pass absent optional parameters. */
return 2;
@@ -674,6 +674,31 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
return gfc_finish_block (&se.pre);
}
+/* Translate the FAIL IMAGE statement. */
+
+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)
@@ -56,6 +56,7 @@ tree gfc_trans_select_type (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 *);
@@ -1953,6 +1953,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;
@@ -833,6 +833,10 @@ 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_caf_stopped_images;
extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
new file mode 100644
@@ -0,0 +1,9 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+program fail_statement
+ implicit none
+
+ fail image
+
+end program fail_statement
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,9 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" -lcaf_single}
+!
+program test_image_status
+ implicit none
+
+ write(*,*) image_status(1)
+
+end program test_image_status
new file mode 100644
@@ -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" } }
new file mode 100644
@@ -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" } }
new file mode 100644
@@ -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
new file mode 100644
@@ -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" } }
new file mode 100644
@@ -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
@@ -243,6 +243,15 @@ 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_fail_image (void);
+void _gfortran_caf_failed_images (gfc_descriptor_t *,
+ int __attribute__ ((unused)),
+ int __attribute__ ((unused)));
+int _gfortran_caf_image_status (int);
+void _gfortran_caf_stopped_images (gfc_descriptor_t *,
+ int __attribute__ ((unused)),
+ int __attribute__ ((unused)));
+
int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
#endif /* LIBCAF_H */
@@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include <string.h> /* For memcpy and memset. */
#include <stdarg.h> /* For variadic arguments. */
#include <assert.h>
+#include <signal.h>
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
@@ -2881,3 +2882,43 @@ _gfortran_caf_lock (caf_token_t token, size_t index,
_gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
}
+void _gfortran_caf_fail_image (void)
+{
+ raise(SIGKILL);
+}
+
+int _gfortran_caf_image_status (int image)
+{
+ if(image == 1)
+ return 0;
+ else
+ return 6000;
+}
+
+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 = 0;
+ array->dim[0]._stride = 1;
+ array->offset = -1;
+}
+
+void
+_gfortran_caf_stopped_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 = 0;
+ array->dim[0]._stride = 1;
+ array->offset = -1;
+}
Dear all, please find in attachment a new patch following the discussion at https://gcc.gnu.org/ml/fortran/2017-01/msg00054.html. Suggestions on how to fix potential issues are more than welcome. Regards, Alessandro commit e2dad3cc56447daea85c147f08b3f58a8e70617f Author: Alessandro Fanfarillo <elfanfa@ucar.edu> Date: Fri Feb 10 13:45:37 2017 -0700 Resurrected patch and tests void _gfortran_caf_unlock (caf_token_t token, size_t index,