diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/array.cc | 172 | ||||
| -rw-r--r-- | gcc/fortran/coarray.cc | 2 | ||||
| -rw-r--r-- | gcc/fortran/expr.cc | 12 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 9 | ||||
| -rw-r--r-- | gcc/fortran/resolve.cc | 75 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.cc | 9 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 50 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90 | 44 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 | 30 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08 | 13 |
10 files changed, 342 insertions, 74 deletions
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 841a0ac..fa177fa 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -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; } diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index f53de0b..7058325 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -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; diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index e4ab3ba..9d84e76 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cf48d02..7c6e9b6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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, ...); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 027c993..34c8210 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -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; } diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 9250304..8ab290b 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -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 diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index c97829f..373a067 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -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); diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90 new file mode 100644 index 0000000..05754d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_2.f90 @@ -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 + + diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 new file mode 100644 index 0000000..29c2b3a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08 new file mode 100644 index 0000000..acd1e3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_4.f08 @@ -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 + |