Fortran: Add F2018 TEAM_NUMBER to coindexed expressions [PR98903]
Add missing parsing and code generation for a[..., TEAM_NUMBER=...] as defined from F2015 onwards. Because F2015 is not used as dedicated standard in GFortran add it to the F2018 standard feature set. PR fortran/98903 gcc/fortran/ChangeLog: * array.cc (gfc_copy_array_ref): Copy team, team_type and stat. (match_team_or_stat): Match a single team(_number)= or stat=. (gfc_match_array_ref): Add switching to image_selector_parsing and error handling when indices come after named arguments. * coarray.cc (move_coarray_ref): Move also team_type. * expr.cc (gfc_free_ref_list): Free team and stat expression. (gfc_find_team_co): Find team or team_number in array-ref. * gfortran.h (enum gfc_array_ref_team_type): New enum to distinguish unset, team or team_number expression. (gfc_find_team_co): Default searching to team= expressions. * resolve.cc (resolve_array_ref): Check for type correctness of team(_number) and stats in coindices. * trans-array.cc (gfc_conv_array_ref): Ensure stat is cleared when fcoarray=single is used. * trans-intrinsic.cc (conv_stat_and_team): Including team_number in conversion. (gfc_conv_intrinsic_caf_get): Propagate team_number to ABI routine. (conv_caf_send_to_remote): Same. (conv_caf_sendget): Same. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/coindexed_2.f90: New test. * gfortran.dg/coarray/coindexed_3.f08: New test. * gfortran.dg/coarray/coindexed_4.f08: New test.
This commit is contained in:
Andre Vehreschild
parent
52e297a3aa
commit
baa9b2b8d2
10 changed files with 342 additions and 74 deletions
|
|
@ -51,6 +51,9 @@ gfc_copy_array_ref (gfc_array_ref *src)
|
|||
dest->stride[i] = gfc_copy_expr (src->stride[i]);
|
||||
}
|
||||
|
||||
dest->stat = gfc_copy_expr (src->stat);
|
||||
dest->team = gfc_copy_expr (src->team);
|
||||
|
||||
return dest;
|
||||
}
|
||||
|
||||
|
|
@ -172,6 +175,76 @@ matched:
|
|||
return (saw_boz ? MATCH_ERROR : MATCH_YES);
|
||||
}
|
||||
|
||||
/** Match one of TEAM=, TEAM_NUMBER= or STAT=. */
|
||||
|
||||
match
|
||||
match_team_or_stat (gfc_array_ref *ar)
|
||||
{
|
||||
gfc_expr *tmp;
|
||||
bool team_error = false;
|
||||
|
||||
if (gfc_match (" team = %e", &tmp) == MATCH_YES)
|
||||
{
|
||||
if (ar->team == NULL && ar->team_type == TEAM_UNSET)
|
||||
{
|
||||
ar->team = tmp;
|
||||
ar->team_type = TEAM_TEAM;
|
||||
}
|
||||
else if (ar->team_type == TEAM_TEAM)
|
||||
{
|
||||
gfc_error ("Duplicate TEAM= attribute in %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
else
|
||||
team_error = true;
|
||||
}
|
||||
else if (gfc_match (" team_number = %e", &tmp) == MATCH_YES)
|
||||
{
|
||||
if (!gfc_notify_std (GFC_STD_F2018, "TEAM_NUMBER= not supported at %C"))
|
||||
return MATCH_ERROR;
|
||||
if (ar->team == NULL && ar->team_type == TEAM_UNSET)
|
||||
{
|
||||
ar->team = tmp;
|
||||
ar->team_type = TEAM_NUMBER;
|
||||
}
|
||||
else if (ar->team_type == TEAM_NUMBER)
|
||||
{
|
||||
gfc_error ("Duplicate TEAM_NUMBER= attribute in %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
else
|
||||
team_error = true;
|
||||
}
|
||||
else if (gfc_match (" stat = %e", &tmp) == MATCH_YES)
|
||||
{
|
||||
if (ar->stat == NULL)
|
||||
{
|
||||
if (gfc_is_coindexed (tmp))
|
||||
{
|
||||
gfc_error ("Expression in STAT= at %C must not be coindexed");
|
||||
gfc_free_expr (tmp);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
ar->stat = tmp;
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_error ("Duplicate STAT= attribute in %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
}
|
||||
else
|
||||
return MATCH_NO;
|
||||
|
||||
if (ar->team && team_error)
|
||||
{
|
||||
gfc_error ("Only one of TEAM= or TEAM_NUMBER= may appear in a "
|
||||
"coarray reference at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
/* Match an array reference, whether it is the whole array or particular
|
||||
elements or a section. If init is set, the reference has to consist
|
||||
|
|
@ -183,9 +256,6 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
|
|||
{
|
||||
match m;
|
||||
bool matched_bracket = false;
|
||||
gfc_expr *tmp;
|
||||
bool stat_just_seen = false;
|
||||
bool team_just_seen = false;
|
||||
|
||||
memset (ar, '\0', sizeof (*ar));
|
||||
|
||||
|
|
@ -272,65 +342,24 @@ coarray:
|
|||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
ar->stat = NULL;
|
||||
ar->team_type = TEAM_UNSET;
|
||||
|
||||
for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
|
||||
for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS;
|
||||
ar->codimen++)
|
||||
{
|
||||
m = match_subscript (ar, init, true);
|
||||
if (m == MATCH_ERROR)
|
||||
return MATCH_ERROR;
|
||||
|
||||
team_just_seen = false;
|
||||
stat_just_seen = false;
|
||||
if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL)
|
||||
{
|
||||
ar->team = tmp;
|
||||
team_just_seen = true;
|
||||
}
|
||||
|
||||
if (ar->team && !team_just_seen)
|
||||
{
|
||||
gfc_error ("TEAM= attribute in %C misplaced");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL)
|
||||
{
|
||||
ar->stat = tmp;
|
||||
stat_just_seen = true;
|
||||
}
|
||||
|
||||
if (ar->stat && !stat_just_seen)
|
||||
{
|
||||
gfc_error ("STAT= attribute in %C misplaced");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
if (gfc_match_char (']') == MATCH_YES)
|
||||
{
|
||||
ar->codimen++;
|
||||
if (ar->codimen < corank)
|
||||
{
|
||||
gfc_error ("Too few codimensions at %C, expected %d not %d",
|
||||
corank, ar->codimen);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
if (ar->codimen > corank)
|
||||
{
|
||||
gfc_error ("Too many codimensions at %C, expected %d not %d",
|
||||
corank, ar->codimen);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
if (gfc_match_char (',') != MATCH_YES)
|
||||
{
|
||||
if (gfc_match_char ('*') == MATCH_YES)
|
||||
gfc_error ("Unexpected %<*%> for codimension %d of %d at %C",
|
||||
ar->codimen + 1, corank);
|
||||
else
|
||||
gfc_error ("Invalid form of coarray reference at %C");
|
||||
{
|
||||
goto image_selector;
|
||||
}
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR)
|
||||
|
|
@ -340,6 +369,15 @@ coarray:
|
|||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
m = match_team_or_stat (ar);
|
||||
if (m == MATCH_ERROR)
|
||||
return MATCH_ERROR;
|
||||
else if (m == MATCH_YES)
|
||||
goto image_selector;
|
||||
|
||||
if (gfc_match_char (']') == MATCH_YES)
|
||||
goto rank_check;
|
||||
|
||||
if (ar->codimen >= corank)
|
||||
{
|
||||
gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
|
||||
|
|
@ -352,6 +390,40 @@ coarray:
|
|||
GFC_MAX_DIMENSIONS);
|
||||
return MATCH_ERROR;
|
||||
|
||||
image_selector:
|
||||
for (;;)
|
||||
{
|
||||
m = match_team_or_stat (ar);
|
||||
if (m == MATCH_ERROR)
|
||||
return MATCH_ERROR;
|
||||
|
||||
if (gfc_match_char (']') == MATCH_YES)
|
||||
goto rank_check;
|
||||
|
||||
if (gfc_match_char (',') != MATCH_YES)
|
||||
{
|
||||
gfc_error ("Invalid form of coarray reference at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
}
|
||||
|
||||
return MATCH_ERROR;
|
||||
|
||||
rank_check:
|
||||
ar->codimen++;
|
||||
if (ar->codimen < corank)
|
||||
{
|
||||
gfc_error ("Too few codimensions at %C, expected %d not %d", corank,
|
||||
ar->codimen);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
if (ar->codimen > corank)
|
||||
{
|
||||
gfc_error ("Too many codimensions at %C, expected %d not %d", corank,
|
||||
ar->codimen);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
return MATCH_YES;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -265,6 +265,8 @@ move_coarray_ref (gfc_ref **from, gfc_expr *expr)
|
|||
(*from)->u.ar.stat = nullptr;
|
||||
to->u.ar.team = (*from)->u.ar.team;
|
||||
(*from)->u.ar.team = nullptr;
|
||||
to->u.ar.team_type = (*from)->u.ar.team_type;
|
||||
(*from)->u.ar.team_type = TEAM_UNSET;
|
||||
for (i = 0; i < to->u.ar.dimen; ++i)
|
||||
{
|
||||
to->u.ar.start[i] = nullptr;
|
||||
|
|
|
|||
|
|
@ -629,6 +629,8 @@ gfc_free_ref_list (gfc_ref *p)
|
|||
gfc_free_expr (p->u.ar.stride[i]);
|
||||
}
|
||||
|
||||
gfc_free_expr (p->u.ar.stat);
|
||||
gfc_free_expr (p->u.ar.team);
|
||||
break;
|
||||
|
||||
case REF_SUBSTRING:
|
||||
|
|
@ -5840,18 +5842,20 @@ gfc_ref_this_image (gfc_ref *ref)
|
|||
}
|
||||
|
||||
gfc_expr *
|
||||
gfc_find_team_co (gfc_expr *e)
|
||||
gfc_find_team_co (gfc_expr *e, enum gfc_array_ref_team_type req_team_type)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
|
||||
&& ref->u.ar.team_type == req_team_type)
|
||||
return ref->u.ar.team;
|
||||
|
||||
if (e->value.function.actual->expr)
|
||||
if (e->expr_type == EXPR_FUNCTION && e->value.function.actual->expr)
|
||||
for (ref = e->value.function.actual->expr->ref; ref;
|
||||
ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
|
||||
&& ref->u.ar.team_type == req_team_type)
|
||||
return ref->u.ar.team;
|
||||
|
||||
return NULL;
|
||||
|
|
|
|||
|
|
@ -2408,12 +2408,18 @@ enum gfc_array_ref_dimen_type
|
|||
DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN
|
||||
};
|
||||
|
||||
enum gfc_array_ref_team_type
|
||||
{
|
||||
TEAM_UNKNOWN = 0, TEAM_UNSET, TEAM_TEAM, TEAM_NUMBER
|
||||
};
|
||||
|
||||
typedef struct gfc_array_ref
|
||||
{
|
||||
ar_type type;
|
||||
int dimen; /* # of components in the reference */
|
||||
int codimen;
|
||||
bool in_allocate; /* For coarray checks. */
|
||||
enum gfc_array_ref_team_type team_type : 2;
|
||||
gfc_expr *team;
|
||||
gfc_expr *stat;
|
||||
locus where;
|
||||
|
|
@ -3936,7 +3942,8 @@ bool gfc_is_coindexed (gfc_expr *);
|
|||
bool gfc_is_coarray (gfc_expr *);
|
||||
bool gfc_has_ultimate_allocatable (gfc_expr *);
|
||||
bool gfc_has_ultimate_pointer (gfc_expr *);
|
||||
gfc_expr* gfc_find_team_co (gfc_expr *);
|
||||
gfc_expr *gfc_find_team_co (gfc_expr *,
|
||||
gfc_array_ref_team_type req_team_type = TEAM_TEAM);
|
||||
gfc_expr* gfc_find_stat_co (gfc_expr *);
|
||||
gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
|
||||
locus, unsigned, ...);
|
||||
|
|
|
|||
|
|
@ -5458,6 +5458,81 @@ resolve_array_ref (gfc_array_ref *ar)
|
|||
ar->dimen_type[n] = DIMEN_THIS_IMAGE;
|
||||
}
|
||||
|
||||
if (ar->codimen)
|
||||
{
|
||||
if (ar->team_type == TEAM_NUMBER)
|
||||
{
|
||||
if (!gfc_resolve_expr (ar->team))
|
||||
return false;
|
||||
|
||||
if (ar->team->rank != 0)
|
||||
{
|
||||
gfc_error ("TEAM_NUMBER argument at %L must be scalar",
|
||||
&ar->team->where);
|
||||
return false;
|
||||
}
|
||||
|
||||
if (ar->team->ts.type != BT_INTEGER)
|
||||
{
|
||||
gfc_error ("TEAM_NUMBER argument at %L must be of INTEGER "
|
||||
"type, found %s",
|
||||
&ar->team->where,
|
||||
gfc_basic_typename (ar->team->ts.type));
|
||||
return false;
|
||||
}
|
||||
}
|
||||
else if (ar->team_type == TEAM_TEAM)
|
||||
{
|
||||
if (!gfc_resolve_expr (ar->team))
|
||||
return false;
|
||||
|
||||
if (ar->team->rank != 0)
|
||||
{
|
||||
gfc_error ("TEAM argument at %L must be scalar",
|
||||
&ar->team->where);
|
||||
return false;
|
||||
}
|
||||
|
||||
if (ar->team->ts.type != BT_DERIVED
|
||||
|| ar->team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
|
||||
|| ar->team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
|
||||
{
|
||||
gfc_error ("TEAM argument at %L must be of TEAM_TYPE from "
|
||||
"the intrinsic module ISO_FORTRAN_ENV, found %s",
|
||||
&ar->team->where,
|
||||
gfc_basic_typename (ar->team->ts.type));
|
||||
return false;
|
||||
}
|
||||
}
|
||||
if (ar->stat)
|
||||
{
|
||||
if (!gfc_resolve_expr (ar->stat))
|
||||
return false;
|
||||
|
||||
if (ar->stat->rank != 0)
|
||||
{
|
||||
gfc_error ("STAT argument at %L must be scalar",
|
||||
&ar->stat->where);
|
||||
return false;
|
||||
}
|
||||
|
||||
if (ar->stat->ts.type != BT_INTEGER)
|
||||
{
|
||||
gfc_error ("STAT argument at %L must be of INTEGER "
|
||||
"type, found %s",
|
||||
&ar->stat->where,
|
||||
gfc_basic_typename (ar->stat->ts.type));
|
||||
return false;
|
||||
}
|
||||
|
||||
if (ar->stat->expr_type != EXPR_VARIABLE)
|
||||
{
|
||||
gfc_error ("STAT's expression at %L must be a variable",
|
||||
&ar->stat->where);
|
||||
return false;
|
||||
}
|
||||
}
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -4198,6 +4198,15 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
|
|||
gfc_symbol * sym = expr->symtree->n.sym;
|
||||
char *var_name = NULL;
|
||||
|
||||
if (ar->stat)
|
||||
{
|
||||
gfc_se statse;
|
||||
|
||||
gfc_init_se (&statse, NULL);
|
||||
gfc_conv_expr_lhs (&statse, ar->stat);
|
||||
gfc_add_block_to_block (&se->pre, &statse.pre);
|
||||
gfc_add_modify (&se->pre, statse.expr, integer_zero_node);
|
||||
}
|
||||
if (ar->dimen == 0)
|
||||
{
|
||||
gcc_assert (ar->codimen || sym->attr.select_rank_temporary
|
||||
|
|
|
|||
|
|
@ -1160,7 +1160,8 @@ conv_shape_to_cst (gfc_expr *e)
|
|||
}
|
||||
|
||||
static void
|
||||
conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team)
|
||||
conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
|
||||
tree *team_no)
|
||||
{
|
||||
gfc_expr *stat_e, *team_e;
|
||||
|
||||
|
|
@ -1177,7 +1178,7 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team)
|
|||
else
|
||||
*stat = null_pointer_node;
|
||||
|
||||
team_e = gfc_find_team_co (expr);
|
||||
team_e = gfc_find_team_co (expr, TEAM_TEAM);
|
||||
if (team_e)
|
||||
{
|
||||
gfc_se team_se;
|
||||
|
|
@ -1189,6 +1190,19 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team)
|
|||
}
|
||||
else
|
||||
*team = null_pointer_node;
|
||||
|
||||
team_e = gfc_find_team_co (expr, TEAM_NUMBER);
|
||||
if (team_e)
|
||||
{
|
||||
gfc_se team_se;
|
||||
gfc_init_se (&team_se, NULL);
|
||||
gfc_conv_expr_reference (&team_se, team_e);
|
||||
*team_no = team_se.expr;
|
||||
gfc_add_block_to_block (block, &team_se.pre);
|
||||
gfc_add_block_to_block (block, &team_se.post);
|
||||
}
|
||||
else
|
||||
*team_no = null_pointer_node;
|
||||
}
|
||||
|
||||
/* Get data from a remote coarray. */
|
||||
|
|
@ -1200,7 +1214,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
|
|||
gfc_expr *array_expr;
|
||||
tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
|
||||
dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
|
||||
opt_src_desc, opt_src_charlen, opt_dest_charlen, team;
|
||||
opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
|
||||
symbol_attribute caf_attr_store;
|
||||
gfc_namespace *ns;
|
||||
gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
|
||||
|
|
@ -1231,7 +1245,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
|
|||
|
||||
res_var = lhs;
|
||||
|
||||
conv_stat_and_team (&se->pre, expr, &stat, &team);
|
||||
conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
|
||||
|
||||
get_fn_index_tree
|
||||
= conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
|
||||
|
|
@ -1335,8 +1349,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
|
|||
input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
|
||||
opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
|
||||
opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
|
||||
get_fn_index_tree, add_data_tree, add_data_size, stat, team,
|
||||
null_pointer_node);
|
||||
get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
|
||||
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
|
|
@ -1397,7 +1410,7 @@ conv_caf_send_to_remote (gfc_code *code)
|
|||
stmtblock_t block;
|
||||
gfc_namespace *ns;
|
||||
tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
|
||||
tree lhs_stat, lhs_team, opt_lhs_charlen, opt_rhs_charlen;
|
||||
tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
|
||||
tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
|
||||
tree receiver_fn_index_tree, add_data_tree, add_data_size;
|
||||
|
||||
|
|
@ -1529,7 +1542,7 @@ conv_caf_send_to_remote (gfc_code *code)
|
|||
}
|
||||
gfc_add_block_to_block (&block, &rhs_se.pre);
|
||||
|
||||
conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team);
|
||||
conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
|
||||
|
||||
receiver_fn_index_tree
|
||||
= conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
|
||||
|
|
@ -1539,12 +1552,11 @@ conv_caf_send_to_remote (gfc_code *code)
|
|||
add_data_sym, &add_data_size);
|
||||
++caf_call_cnt;
|
||||
|
||||
tmp
|
||||
= build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
|
||||
token, opt_lhs_desc, opt_lhs_charlen, image_index,
|
||||
rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
|
||||
receiver_fn_index_tree, add_data_tree, add_data_size,
|
||||
lhs_stat, lhs_team, null_pointer_node);
|
||||
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
|
||||
token, opt_lhs_desc, opt_lhs_charlen, image_index,
|
||||
rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
|
||||
receiver_fn_index_tree, add_data_tree,
|
||||
add_data_size, lhs_stat, lhs_team, lhs_team_no);
|
||||
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
gfc_add_block_to_block (&block, &lhs_se.post);
|
||||
|
|
@ -1572,7 +1584,7 @@ conv_caf_sendget (gfc_code *code)
|
|||
gfc_se lhs_se;
|
||||
tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
|
||||
opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
|
||||
lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team;
|
||||
lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
|
||||
int transfer_rank;
|
||||
|
||||
/* rhs stuff */
|
||||
|
|
@ -1581,7 +1593,7 @@ conv_caf_sendget (gfc_code *code)
|
|||
gfc_se rhs_se;
|
||||
tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
|
||||
opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
|
||||
rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team;
|
||||
rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
|
||||
|
||||
/* shared */
|
||||
stmtblock_t block;
|
||||
|
|
@ -1758,8 +1770,8 @@ conv_caf_sendget (gfc_code *code)
|
|||
rhs_expr);
|
||||
|
||||
/* stat and team. */
|
||||
conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team);
|
||||
conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team);
|
||||
conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
|
||||
conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
|
||||
|
||||
sender_fn_index_tree
|
||||
= conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
|
||||
|
|
@ -1784,7 +1796,7 @@ conv_caf_sendget (gfc_code *code)
|
|||
opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
|
||||
rhs_add_data_size, rhs_size,
|
||||
transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
|
||||
lhs_team, null_pointer_node, rhs_stat, rhs_team, null_pointer_node);
|
||||
lhs_team, lhs_team_no, rhs_stat, rhs_team, rhs_team_no);
|
||||
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
gfc_add_block_to_block (&block, &lhs_se.post);
|
||||
|
|
|
|||
44
gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90
Normal file
44
gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
!{ dg-do compile }
|
||||
|
||||
program coindexed_2
|
||||
use, intrinsic :: iso_fortran_env
|
||||
|
||||
integer, save :: dim1[*]
|
||||
integer :: ist
|
||||
logical :: cst
|
||||
type(team_type) :: team
|
||||
|
||||
dim1 = 3
|
||||
print *, dim1[1] ! ok
|
||||
print *, dim1['me'] ! { dg-error "Array index at \\\(1\\\) must be of INTEGER" }
|
||||
|
||||
print *, dim1[1, STAT=ist] !ok
|
||||
print *, dim1[1, STAT=cst] ! { dg-error "STAT argument at \\\(1\\\) must be of INTEGER" }
|
||||
print *, dim1[1, STAT=[ist]] ! { dg-error "STAT argument at \\\(1\\\) must be scalar" }
|
||||
print *, dim1[1, STAT=ist, STAT=ist] ! { dg-error "Duplicate" }
|
||||
print *, dim1[STAT=ist, 1] ! { dg-error "Invalid form of" }
|
||||
print *, dim1[5, STAT=ist, 1] ! { dg-error "Invalid form of" }
|
||||
print *, dim1[5, STAT=dim1[1]] ! { dg-error "Expression in STAT= at \\\(1\\\) must not be coindexed" }
|
||||
|
||||
print *, dim1[1, TEAM=team] !ok
|
||||
print *, dim1[1, STAT= ist, TEAM=team] !ok
|
||||
print *, dim1[1, TEAM=team, STAT=ist] !ok
|
||||
print *, dim1[1, STAT=ist, TEAM=team, STAT=ist] ! { dg-error "Duplicate" }
|
||||
print *, dim1[1, TEAM=team, STAT=ist, TEAM=team] ! { dg-error "Duplicate" }
|
||||
print *, dim1[1, TEAM=ist] ! { dg-error "TEAM argument at \\\(1\\\) must be of TEAM_TYPE" }
|
||||
print *, dim1[1, TEAM=[team]] ! { dg-error "TEAM argument at \\\(1\\\) must be scalar" }
|
||||
print *, dim1[TEAM=team, 1] ! { dg-error "Invalid form of" }
|
||||
print *, dim1[5, TEAM=team, 1] ! { dg-error "Invalid form of" }
|
||||
|
||||
print *, dim1[1, TEAM_NUMBER=-1] !ok
|
||||
print *, dim1[1, TEAM_NUMBER=1] !ok
|
||||
print *, dim1[1, TEAM_NUMBER=1.23] ! { dg-error "TEAM_NUMBER argument at \\\(1\\\) must be of INTEGER" }
|
||||
print *, dim1[1, TEAM_NUMBER='me'] ! { dg-error "TEAM_NUMBER argument at \\\(1\\\) must be of INTEGER" }
|
||||
print *, dim1[1, TEAM_NUMBER=5, STAT=ist] !ok
|
||||
print *, dim1[1, TEAM_NUMBER=5, STAT=ist, TEAM_NUMBER=-1] ! { dg-error "Duplicate" }
|
||||
print *, dim1[1, TEAM_NUMBER=-1, TEAM=team] ! { dg-error "Only one of TEAM" }
|
||||
print *, dim1[TEAM_NUMBER=-1, 1] ! { dg-error "Invalid form of" }
|
||||
print *, dim1[5, TEAM_NUMBER=-1, 1] ! { dg-error "Invalid form of" }
|
||||
end program
|
||||
|
||||
|
||||
30
gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
Normal file
30
gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
!{ dg-do run }
|
||||
|
||||
! Check that team_number is supported in coindices.
|
||||
! Adapted from code sent by Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
program pr98903
|
||||
use, intrinsic :: iso_fortran_env
|
||||
integer :: me, n, s
|
||||
integer :: a[*]
|
||||
type(team_type) :: team
|
||||
|
||||
me = this_image()
|
||||
n = num_images()
|
||||
a = 42
|
||||
s = 42
|
||||
|
||||
! Checking against single image only. Therefore team statements are
|
||||
! not viable nor are they (yet) supported by GFortran.
|
||||
if (a[1, team_number=-1, stat=s] /= 42) stop 1
|
||||
if (s /= 0) stop 2
|
||||
|
||||
s = 42
|
||||
if (a[1, team = team, stat=s] /= 42) stop 3
|
||||
if (s /= 0) stop 4
|
||||
|
||||
s = 42
|
||||
if (a[1, stat=s] /= 42) stop 5
|
||||
if (s /= 0) stop 6
|
||||
end program pr98903
|
||||
|
||||
13
gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08
Normal file
13
gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
!{ dg-do compile }
|
||||
!{ dg-additional-options "-std=f2008" }
|
||||
|
||||
! TEAM_NUMBER= in coindices has been introduced in F2015 standard, but that is not
|
||||
! dedicatedly supported by GFortran. Therefore check for F2018.
|
||||
program pr98903
|
||||
integer :: a[*]
|
||||
|
||||
a = 42
|
||||
|
||||
a = a[1, team_number=-1] ! { dg-error "Fortran 2018: TEAM_NUMBER= not supported at" }
|
||||
end program pr98903
|
||||
|
||||
Loading…
Add table
Reference in a new issue