From b13acf8c232c3d5f96383427ed856a89fc1545f2 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Thu, 6 Mar 2025 15:14:24 +0100
Subject: [PATCH] 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 indexes 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 coindexes.
* 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.
---
gcc/fortran/array.cc | 172 +++++++++++++-----
gcc/fortran/coarray.cc | 2 +
gcc/fortran/expr.cc | 12 +-
gcc/fortran/gfortran.h | 9 +-
gcc/fortran/resolve.cc | 75 ++++++++
gcc/fortran/trans-array.cc | 9 +
gcc/fortran/trans-intrinsic.cc | 50 +++--
.../gfortran.dg/coarray/coindexed_2.f90 | 44 +++++
.../gfortran.dg/coarray/coindexed_3.f08 | 30 +++
.../gfortran.dg/coarray/coindexed_4.f08 | 13 ++
10 files changed, 342 insertions(+), 74 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
create mode 100644 gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08
@@ -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 "
+ "ISO_FORTRAN_ENV module, 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);
new file mode 100644
@@ -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
+
+
new file mode 100644
@@ -0,0 +1,30 @@
+!{ dg-do run }
+
+! Check that team_number is supported in coindezes.
+! 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
+
new file mode 100644
@@ -0,0 +1,13 @@
+!{ dg-do compile }
+!{ dg-additional-options "-std=f2008" }
+
+! TEAM_NUMBER= in coindexes 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
+
--
2.48.1