https://gcc.gnu.org/g:6e6249fc9e9932909089bc5b8cb3618650c9e662
commit r17-4204-g6e6249fc9e9932909089bc5b8cb3618650c9e662 Author: Jerry DeLisle <[email protected]> Date: Fri Sep 11 07:47:41 2026 -0700 fortran: [PR126781] TEAM_NUMBER keyword for NUM_IMAGES and IMAGE_INDEX The TEAM and TEAM_NUMBER arguments of NUM_IMAGES and IMAGE_INDEX shared a single dummy argument named "team/team_number", so neither keyword could be used, and the TEAM argument of IMAGE_INDEX was accepted with -std=f2008. Give each its own optional dummy argument, of type TEAM_TYPE and INTEGER. A positional INTEGER argument is moved to TEAM_NUMBER by the check functions, which now take the actual argument list, and giving both is diagnosed as an error. Both arguments are Fortran 2018. PR fortran/126781 gcc/fortran/ChangeLog: * check.cc (check_team_or_team_number): New function. (gfc_check_image_index, gfc_check_num_images): Take the actual argument list and use it. * intrinsic.cc (add_sym_2red, add_sym_4red): New functions. (add_functions): Give NUM_IMAGES and IMAGE_INDEX separate TEAM and TEAM_NUMBER arguments. (check_specific): Pass the actual argument list to gfc_check_num_images and gfc_check_image_index. * intrinsic.h (gfc_check_num_images, gfc_check_image_index, gfc_simplify_image_index, gfc_simplify_num_images, gfc_resolve_image_index): Update prototypes. * intrinsic.texi (IMAGE_INDEX, NUM_IMAGES): Document TEAM and TEAM_NUMBER as separate arguments. Fix the NUM_IMAGES example. * iresolve.cc (gfc_resolve_image_index): Add TEAM_NUMBER argument. * simplify.cc (gfc_simplify_num_images, gfc_simplify_image_index): Likewise. * trans-intrinsic.cc (trans_image_index, trans_num_images): Take the team number from the TEAM_NUMBER argument. gcc/testsuite/ChangeLog: * gfortran.dg/coarray_this_image_3.f90: Update expected errors. * gfortran.dg/coarray/num_images_team_1.f90: New test. * gfortran.dg/coarray/num_images_team_2.f90: New test. * gfortran.dg/coarray_team_kw_1.f90: New test. * gfortran.dg/coarray_team_std_1.f90: New test. Diff: --- gcc/fortran/check.cc | 83 ++++++++++++--------- gcc/fortran/intrinsic.cc | 85 +++++++++++++++++++--- gcc/fortran/intrinsic.h | 12 +-- gcc/fortran/intrinsic.texi | 35 ++++++--- gcc/fortran/iresolve.cc | 3 +- gcc/fortran/simplify.cc | 6 +- gcc/fortran/trans-intrinsic.cc | 39 ++++++---- .../gfortran.dg/coarray/num_images_team_1.f90 | 33 +++++++++ .../gfortran.dg/coarray/num_images_team_2.f90 | 38 ++++++++++ gcc/testsuite/gfortran.dg/coarray_team_kw_1.f90 | 26 +++++++ gcc/testsuite/gfortran.dg/coarray_team_std_1.f90 | 18 +++++ gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 | 6 +- 12 files changed, 306 insertions(+), 78 deletions(-) diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 58bcf07fffd6..2064442d57ce 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -6895,10 +6895,54 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status) } +/* Check the TEAM and TEAM_NUMBER arguments of IMAGE_INDEX and NUM_IMAGES, + moving a positional INTEGER argument to TEAM_NUMBER. N is the formal + index of TEAM. */ + +static bool +check_team_or_team_number (gfc_actual_arglist *team_arg, + gfc_actual_arglist *team_number_arg, int n) +{ + gfc_expr *team = team_arg->expr, *team_number = team_number_arg->expr; + + if (team && team_number) + { + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L are mutually " + "exclusive", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic_arg[n + 1]->name, gfc_current_intrinsic, + &team->where); + return false; + } + + if (team && !team_arg->name && team->ts.type == BT_INTEGER) + { + team_number_arg->expr = team; + team_arg->expr = NULL; + team_number = team; + team = NULL; + } + + if (!team && !team_number) + return true; + + if (!gfc_notify_std (GFC_STD_F2018, + "%<team%> or %<team_number%> argument to %qs at %L", + gfc_current_intrinsic, + team ? &team->where : &team_number->where)) + return false; + + if (team) + return scalar_check (team, n) && team_type_check (team, n); + + return type_check (team_number, n + 1, BT_INTEGER) + && scalar_check (team_number, n + 1); +} + + bool -gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub, - gfc_expr *team_or_team_number) +gfc_check_image_index (gfc_actual_arglist *args) { + gfc_expr *coarray = args->expr, *sub = args->next->expr; mpz_t nelems; if (flag_coarray == GFC_FCOARRAY_NONE) @@ -6934,23 +6978,12 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub, mpz_clear (nelems); } - if (team_or_team_number) - { - if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER) - || !scalar_check (team_or_team_number, 2)) - return false; - - /* Check team is of team_type. */ - if (team_or_team_number->ts.type == BT_DERIVED - && !team_type_check (team_or_team_number, 2)) - return false; - } - - return true; + return check_team_or_team_number (args->next->next, + args->next->next->next, 2); } bool -gfc_check_num_images (gfc_expr *team_or_team_number) +gfc_check_num_images (gfc_actual_arglist *args) { if (flag_coarray == GFC_FCOARRAY_NONE) { @@ -6959,23 +6992,7 @@ gfc_check_num_images (gfc_expr *team_or_team_number) return false; } - if (!team_or_team_number) - return true; - - if (!gfc_notify_std (GFC_STD_F2008, - "%<team%> or %<team_number%> argument to %qs at %L", - gfc_current_intrinsic, &team_or_team_number->where)) - return false; - - if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER) - || !scalar_check (team_or_team_number, 0)) - return false; - - if (team_or_team_number->ts.type == BT_DERIVED - && !team_type_check (team_or_team_number, 0)) - return false; - - return true; + return check_team_or_team_number (args, args->next, 0); } diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 0d25de4d9d27..b0c246daeb4e 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -910,6 +910,65 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt } +/* Add a symbol with 2 arguments whose check function takes the actual + argument list. */ + +static void +add_sym_2red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3red = check; + sf.f2 = simplify; + rf.f2 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + (void *) 0); +} + + +/* Likewise with 4 arguments, for IMAGE_INDEX. */ + +static void +add_sym_4red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3red = check; + sf.f4 = simplify; + rf.f4 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + (void *) 0); +} + + /* Add a symbol to the subroutine list where the subroutine takes 3 arguments, specifying the intent of the arguments. */ @@ -1410,7 +1469,7 @@ add_functions (void) *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig", *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b", *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team", - *team_or_team_number = "team/team_number", *tm = "time", *ts = "tsource", + *team_number = "team_number", *tm = "time", *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z"; @@ -2271,11 +2330,11 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); - add_sym_3 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index, - gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, - REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team_or_team_number, - BT_VOID, di, OPTIONAL); + add_sym_4red ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index, + gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, + dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team, BT_DERIVED, + di, OPTIONAL, team_number, BT_INTEGER, di, OPTIONAL); add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, @@ -2856,10 +2915,10 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_1 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, - gfc_simplify_num_images, NULL, team_or_team_number, BT_VOID, di, - OPTIONAL); + add_sym_2red ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, + gfc_simplify_num_images, NULL, team, BT_DERIVED, di, OPTIONAL, + team_number, BT_INTEGER, di, OPTIONAL); add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2018, @@ -5110,6 +5169,12 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) else if (specific->check.f3red == gfc_check_this_image) /* May need to reassign arguments. */ t = gfc_check_this_image (*ap); + else if (specific->check.f3red == gfc_check_num_images) + /* A positional team number has to be moved to its own slot. */ + t = gfc_check_num_images (*ap); + else if (specific->check.f3red == gfc_check_image_index) + /* Likewise. */ + t = gfc_check_image_index (*ap); else { if (specific->check.f1 == NULL) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index ad0c54f29593..b8bfb68d129a 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -133,7 +133,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *); bool gfc_check_new_line (gfc_expr *); bool gfc_check_norm2 (gfc_expr *, gfc_expr *); bool gfc_check_null (gfc_expr *); -bool gfc_check_num_images (gfc_expr *); +bool gfc_check_num_images (gfc_actual_arglist *); bool gfc_check_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_parity (gfc_expr *, gfc_expr *); @@ -225,7 +225,7 @@ bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *); bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); -bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_image_index (gfc_actual_arglist *); bool gfc_check_itime_idate (gfc_expr *); bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -336,7 +336,8 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); 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_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *, 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 *); @@ -391,7 +392,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); -gfc_expr *gfc_simplify_num_images (gfc_expr *); +gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); @@ -542,7 +543,8 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); 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 *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, 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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 7fa08f4ed3b9..0d75b47c57be 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -8775,7 +8775,11 @@ GNU extension @table @asis @item @emph{Synopsis}: -@code{RESULT = IMAGE_INDEX(COARRAY, SUB)} +@multitable @columnfractions .80 +@item @code{RESULT = IMAGE_INDEX(COARRAY, SUB)} +@item @code{RESULT = IMAGE_INDEX(COARRAY, SUB, TEAM)} +@item @code{RESULT = IMAGE_INDEX(COARRAY, SUB, TEAM_NUMBER)} +@end multitable @item @emph{Description}: Returns the image index belonging to a cosubscript. @@ -8788,6 +8792,12 @@ Transformational function @item @var{COARRAY} @tab Coarray of any type. @item @var{SUB} @tab default integer rank-1 array of a size equal to the corank of @var{COARRAY}. +@item @var{TEAM} @tab (optional, intent(in)) Scalar of type +@code{TEAM_TYPE} identifying the current or an ancestor team. If present, +the image index is that in the given team. +@item @var{TEAM_NUMBER} @tab (optional, intent(in)) Integer scalar +identifying the initial team (@code{-1}) or a sibling team of the current +team. @var{TEAM} and @var{TEAM_NUMBER} are mutually exclusive. @end multitable @item @emph{Return value}: @@ -8802,7 +8812,8 @@ WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) @end smallexample @item @emph{Standard}: -Fortran 2008 and later +Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument, +Fortran 2018 and later. @item @emph{See also}: @ref{THIS_IMAGE}, @* @@ -11918,11 +11929,13 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{TEAM} @tab (optional, intent(in)) If present, return the number of -images in the given team; if absent, return the number of images in the -current team. -@item @var{TEAM_NUMBER} @tab (intent(in)) The number as given in the -@code{FORM TEAM} statement. +@item @var{TEAM} @tab (optional, intent(in)) Scalar of type +@code{TEAM_TYPE} identifying the current or an ancestor team. If present, +return the number of images in the given team; if absent, return the number +of images in the current team. +@item @var{TEAM_NUMBER} @tab (optional, intent(in)) Integer scalar +identifying the initial team (@code{-1}) or a sibling team of the current +team. @var{TEAM} and @var{TEAM_NUMBER} are mutually exclusive. @end multitable @item @emph{Return value}: @@ -11939,9 +11952,11 @@ type(team_type) :: t ! When running with 4 images print *, num_images() ! 4 -form team (mod(this_image(), 2), t) -print *, num_images(t) ! 2 -print *, num_images(-1) ! 4 +form team (2 - mod(this_image(), 2), t) +change team (t) + print *, num_images() ! 2 + print *, num_images(team_number=-1) ! 4 +end team @end smallexample @item @emph{Standard}: diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 72cb6c81c4dc..f1c542b70c6c 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3270,7 +3270,8 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, gfc_expr *sub ATTRIBUTE_UNUSED, - gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) + gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *team_number ATTRIBUTE_UNUSED) { static char image_index[] = "__image_index"; f->ts.type = BT_INTEGER; diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 3340a20e227c..ff13b5641952 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -7035,7 +7035,8 @@ gfc_simplify_null (gfc_expr *mold) gfc_expr * -gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) +gfc_simplify_num_images (gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *team_number ATTRIBUTE_UNUSED) { gfc_expr *result; @@ -9227,7 +9228,8 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub, - gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) + gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *team_number ATTRIBUTE_UNUSED) { gfc_expr *result; gfc_ref *ref; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index b7fdaba685d5..6666c46c1fea 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2145,13 +2145,19 @@ trans_image_index (gfc_se * se, gfc_expr *expr) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr); - if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED) - team = argse.expr; - else - team_number = gfc_build_addr_expr ( - NULL_TREE, - gfc_trans_force_lval (&argse.pre, - fold_convert (integer_type_node, argse.expr))); + team = argse.expr; + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + else if (expr->value.function.actual->next->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, + expr->value.function.actual->next->next->next->expr); + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&argse.pre, + fold_convert (integer_type_node, argse.expr))); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); } @@ -2257,13 +2263,18 @@ trans_num_images (gfc_se * se, gfc_expr *expr) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, expr->value.function.actual->expr); - if (expr->value.function.actual->expr->ts.type == BT_DERIVED) - team = argse.expr; - else - team_number = gfc_build_addr_expr ( - NULL_TREE, - gfc_trans_force_lval (&argse.pre, - fold_convert (integer_type_node, argse.expr))); + team = argse.expr; + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + else if (expr->value.function.actual->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&argse.pre, + fold_convert (integer_type_node, argse.expr))); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); } diff --git a/gcc/testsuite/gfortran.dg/coarray/num_images_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/num_images_team_1.f90 new file mode 100644 index 000000000000..31123368de96 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/num_images_team_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR 126781 +! +! The TEAM and TEAM_NUMBER arguments of NUM_IMAGES and IMAGE_INDEX shared a +! single dummy named "team/team_number", so neither keyword could be used. + +program num_images_team_1 + use iso_fortran_env, only : team_type + implicit none + + integer :: caf[*] + type(team_type) :: t + integer :: n, tn + + n = num_images () + t = get_team () + tn = team_number () + + if (num_images (t) /= n) stop 1 + if (num_images (tn) /= n) stop 2 + if (num_images (team = t) /= n) stop 3 + if (num_images (team_number = tn) /= n) stop 4 + if (num_images (team = get_team ()) /= n) stop 5 + if (num_images (team_number = team_number ()) /= n) stop 6 + + if (image_index (caf, [n], team = t) /= n) stop 7 + if (image_index (caf, [n], team_number = tn) /= n) stop 8 + if (image_index (caf, [n], team = get_team ()) /= n) stop 9 + if (image_index (caf, [n], team_number = team_number ()) /= n) stop 10 + if (image_index (coarray = caf, sub = [n], team = t) /= n) stop 11 + if (image_index (sub = [n], coarray = caf, team_number = tn) /= n) stop 12 +end program num_images_team_1 diff --git a/gcc/testsuite/gfortran.dg/coarray/num_images_team_2.f90 b/gcc/testsuite/gfortran.dg/coarray/num_images_team_2.f90 new file mode 100644 index 000000000000..ea0013cd06a3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/num_images_team_2.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } } +! +! PR 126781 +! +! TEAM and TEAM_NUMBER arguments of NUM_IMAGES and IMAGE_INDEX inside a +! CHANGE TEAM construct. + +program num_images_team_2 + use iso_fortran_env, only : team_type, initial_team, parent_team + implicit none + + integer :: caf[*] + type(team_type) :: t + integer :: n, m, tn + + n = num_images () + form team (2 - mod (this_image (), 2), t) + + change team (t) + m = num_images () + tn = team_number () + + if (num_images (team_number = tn) /= m) stop 1 + if (num_images (tn) /= m) stop 2 + if (num_images (team_number = -1) /= n) stop 3 + if (num_images (team = get_team (initial_team)) /= n) stop 4 + if (num_images (team = get_team (parent_team)) /= n) stop 5 + if (num_images (get_team ()) /= m) stop 6 + + if (image_index (caf, [1], team_number = tn) /= 1) stop 7 + if (image_index (caf, [m], team_number = tn) /= m) stop 8 + if (image_index (caf, [m + 1], team_number = tn) /= 0) stop 9 + if (image_index (caf, [n], team = get_team (initial_team)) /= n) stop 10 + if (image_index (caf, [n + 1], team = get_team (parent_team)) /= 0) stop 11 + if (image_index (caf, [m], get_team ()) /= m) stop 12 + end team +end program num_images_team_2 diff --git a/gcc/testsuite/gfortran.dg/coarray_team_kw_1.f90 b/gcc/testsuite/gfortran.dg/coarray_team_kw_1.f90 new file mode 100644 index 000000000000..7be27b923f16 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_team_kw_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! PR 126781 +! +! TEAM and TEAM_NUMBER are separate arguments of NUM_IMAGES and IMAGE_INDEX: +! each keyword accepts only its own type, and at most one may be given. + +program coarray_team_kw_1 + use iso_fortran_env, only : team_type + implicit none + + integer :: caf[*], r, n + type(team_type) :: t + + t = get_team () + n = 1 + + r = num_images (team = n) ! { dg-error "shall be of type 'team_type'" } + r = num_images (team_number = t) ! { dg-error "must be INTEGER" } + r = num_images (team = t, team_number = n) ! { dg-error "are mutually exclusive" } + + r = image_index (caf, [1], team = n) ! { dg-error "shall be of type 'team_type'" } + r = image_index (caf, [1], team_number = t) ! { dg-error "must be INTEGER" } + r = image_index (caf, [1], team = t, team_number = n) ! { dg-error "are mutually exclusive" } +end program coarray_team_kw_1 diff --git a/gcc/testsuite/gfortran.dg/coarray_team_std_1.f90 b/gcc/testsuite/gfortran.dg/coarray_team_std_1.f90 new file mode 100644 index 000000000000..7079341e6b59 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_team_std_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -std=f2008" } +! +! PR 126781 +! +! The TEAM/TEAM_NUMBER argument of NUM_IMAGES was gated on Fortran 2008 and +! that of IMAGE_INDEX was not gated at all; both are Fortran 2018. + +program coarray_team_std_1 + implicit none + + integer :: caf[*], r + + r = num_images () ! ok + r = num_images (1) ! { dg-error "Fortran 2018: 'team' or 'team_number' argument" } + r = image_index (caf, [1]) ! ok + r = image_index (caf, [1], 1) ! { dg-error "Fortran 2018: 'team' or 'team_number' argument" } +end program coarray_team_std_1 diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 index b8433b20538d..1c09e2cb53fe 100644 --- a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 @@ -24,8 +24,8 @@ j6 = this_image(dim=1, team=team, coarray=caf) k1 = num_images() ! ok k2 = num_images(team) ! ok -k3 = num_images(team, 2) !{ dg-error "Too many arguments in call to" } +k3 = num_images(team, 2) !{ dg-error "are mutually exclusive" } k4 = num_images(1) ! ok -k5 = num_images('abc') !{ dg-error "'team/team_number' argument of 'num_images' intrinsic" } -k6 = num_images(1, team) !{ dg-error "Too many arguments in call to" } +k5 = num_images('abc') !{ dg-error "'team' argument of 'num_images' intrinsic" } +k6 = num_images(1, team) !{ dg-error "are mutually exclusive" } end
