The attached patch is fairly straight forward. I had to add the missing optional
keywords in a few places.
Regression tested on x85_64.
OK for trunk?
Regards,
Jerry
---
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.
---From 765d0bd1a3bad4606552af3ec30c478c2cfdfc9a Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 11 Sep 2026 07:47:41 -0700
Subject: [PATCH] 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.
---
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 +++++++++
.../gfortran.dg/coarray_team_kw_1.f90 | 26 ++++++
.../gfortran.dg/coarray_team_std_1.f90 | 18 ++++
.../gfortran.dg/coarray_this_image_3.f90 | 6 +-
12 files changed, 306 insertions(+), 78 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/num_images_team_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/num_images_team_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray_team_kw_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray_team_std_1.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 58bcf07fffd..2064442d57c 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 0d25de4d9d2..b0c246daeb4 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 ad0c54f2959..b8bfb68d129 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 7fa08f4ed3b..0d75b47c57b 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 72cb6c81c4d..f1c542b70c6 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 b1448a8f684..f0b36c06687 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -7039,7 +7039,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;
@@ -9231,7 +9232,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 3c2c9de162c..c99e7ffb409 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2193,13 +2193,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);
}
@@ -2305,13 +2311,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 00000000000..31123368de9
--- /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 00000000000..ea0013cd06a
--- /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 00000000000..7be27b923f1
--- /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 00000000000..7079341e6b5
--- /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 b8433b20538..1c09e2cb53f 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
--
2.55.0
