https://gcc.gnu.org/g:14a014516ece49714a91e3c67b5a7c56834e8af3
commit r16-78-g14a014516ece49714a91e3c67b5a7c56834e8af3
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Thu Apr 3 10:11:50 2025 +0200
Fortran: Add teams support in image_index and num_images for F2018
This more or less completes the set of functions that are affected by
teams.
gcc/fortran/ChangeLog:
* check.cc (gfc_check_image_index): Check for team or
team_number correctnes.
(gfc_check_num_images): Same.
* gfortran.texi: Update documentation on num_images' API
function.
* intrinsic.cc (add_functions): Update signature of image_index
and num_images. Both can take either a team handle or number.
* intrinsic.h (gfc_check_num_images): Update signature to take
either team or team_number.
(gfc_check_image_index): Can take coarray, subscripts and team
or team number now.
(gfc_simplify_image_index): Same.
(gfc_simplify_num_images): Same.
(gfc_resolve_image_index): Same.
* intrinsic.texi: Update documentation of num_images() Fortran
function.
* iresolve.cc (gfc_resolve_image_index): Update signature.
* simplify.cc (gfc_simplify_num_images): Update signature and
remove undocumented failed argument.
(gfc_simplify_image_index): Add team or team number argument.
* trans-intrinsic.cc (conv_stat_and_team): Because being
optional teams need to be a pointer to the opaque pointer.
(conv_caf_sendget): Correct call; was two arguments short.
(trans_image_index): Support team or team_number.
(trans_num_images): Same.
(conv_intrinsic_cobound): Adapt to changed signature of
num_images in call.
* trans-stmt.cc (gfc_trans_sync): Same.
libgfortran/ChangeLog:
* caf/libcaf.h (_gfortran_caf_num_images): Correct prototype.
* caf/single.c (_gfortran_caf_num_images): Default
implementation.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray_49.f90: Adapt to changed error message.
* gfortran.dg/coarray_collectives_12.f90: Adapt to changed
function signature of num_images.
* gfortran.dg/coarray_collectives_16.f90: Same.
* gfortran.dg/coarray_lib_this_image_1.f90: Same.
* gfortran.dg/coarray_lib_this_image_2.f90: Same.
* gfortran.dg/coarray_this_image_1.f90: Adapt tests for
num_images.
* gfortran.dg/coarray_this_image_2.f90: Same.
* gfortran.dg/coarray_this_image_3.f90: Same.
* gfortran.dg/num_images_1.f90: Check that deprecated syntax is
no longer supported.
Diff:
---
gcc/fortran/check.cc | 63 ++++++++++-----------
gcc/fortran/gfortran.texi | 26 +++++----
gcc/fortran/intrinsic.cc | 55 +++++++++---------
gcc/fortran/intrinsic.h | 10 ++--
gcc/fortran/intrinsic.texi | 45 +++++++--------
gcc/fortran/iresolve.cc | 3 +-
gcc/fortran/simplify.cc | 12 +---
gcc/fortran/trans-intrinsic.cc | 66 +++++++++++++---------
gcc/fortran/trans-stmt.cc | 3 +-
gcc/testsuite/gfortran.dg/coarray_49.f90 | 2 +-
.../gfortran.dg/coarray_collectives_12.f90 | 2 +-
.../gfortran.dg/coarray_collectives_16.f90 | 2 +-
.../gfortran.dg/coarray_lib_this_image_1.f90 | 2 +-
.../gfortran.dg/coarray_lib_this_image_2.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 | 14 ++---
gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 | 16 +++---
gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 | 15 ++---
gcc/testsuite/gfortran.dg/num_images_1.f90 | 2 +-
libgfortran/caf/libcaf.h | 2 +-
libgfortran/caf/single.c | 4 +-
20 files changed, 171 insertions(+), 175 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index c27f653d3b06..356e0d7f678c 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6565,7 +6565,8 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array,
gfc_expr *status)
bool
-gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
+gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub,
+ gfc_expr *team_or_team_number)
{
mpz_t nelems;
@@ -6585,12 +6586,8 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
return false;
}
- if (sub->ts.type != BT_INTEGER)
- {
- gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER",
- gfc_current_intrinsic_arg[1]->name, &sub->where);
- return false;
- }
+ if (!type_check (sub, 1, BT_INTEGER))
+ return false;
if (gfc_array_size (sub, &nelems))
{
@@ -6605,12 +6602,23 @@ 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;
}
-
bool
-gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
+gfc_check_num_images (gfc_expr *team_or_team_number)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
@@ -6618,34 +6626,21 @@ gfc_check_num_images (gfc_expr *distance, gfc_expr
*failed)
return false;
}
- if (distance)
- {
- if (!type_check (distance, 0, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("DISTANCE", distance))
- return false;
-
- if (!scalar_check (distance, 0))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
- "NUM_IMAGES at %L", &distance->where))
- return false;
- }
+ if (!team_or_team_number)
+ return true;
- if (failed)
- {
- if (!type_check (failed, 1, BT_LOGICAL))
- return false;
+ 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 (!scalar_check (failed, 1))
- return false;
+ if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER)
+ || !scalar_check (team_or_team_number, 0))
+ return false;
- if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to "
- "NUM_IMAGES at %L", &failed->where))
- return false;
- }
+ if (team_or_team_number->ts.type == BT_DERIVED
+ && !team_type_check (team_or_team_number, 0))
+ return false;
return true;
}
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 33ac6d43ab86..841f61350660 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4326,25 +4326,29 @@ be null here.
@table @asis
@item @emph{Synopsis}:
-@code{int _gfortran_caf_num_images(int distance, int failed)}
+@code{int _gfortran_caf_num_images (caf_team_t team, int32_t *team_number)}
@item @emph{Description}:
-This function returns the number of images in the current team, if
-@var{distance} is 0 or the number of images in the parent team at the specified
-distance. If @var{failed} is -1, the function returns the number of all images
at
-the specified distance; if it is 0, the function returns the number of
-nonfailed images, and if it is 1, it returns the number of failed images.
+This function returns the number of images in the team given by @var{team} or
+@var{team_number}, if either one is present. If both are null, then the number
+of images in the current team is returned.
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{distance} @tab the distance from this image to the ancestor.
-Shall be positive.
-@item @var{failed} @tab shall be -1, 0, or 1
+@item @var{team} @tab intent(in), optional; The team the number of images is
+requested for. If null, the number of images in the current team is returned.
+@item @var{team_number} @tab intent(in), optional; The team id for which the
+number of teams is requested; if unset, then number of images in the current
+team is returned.
@end multitable
@item @emph{Notes}:
-This function follows TS18508. If the num_image intrinsic has no arguments,
-then the compiler passes @code{distance=0} and @code{failed=-1} to the
function.
+When both argument are given, then it is caf-library dependent which argument
+is examined first. Current implementations prioritize the @var{team} argument,
+because it is easier to retrive the number of images from it.
+
+Fortran 2008 or later, with no arguments; Fortran 2018 or later with two
+arguments.
@end table
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index ce586a20ad5e..2eba2094606e 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -1395,26 +1395,24 @@ add_functions (void)
{
/* Argument names. These are used as argument keywords and so need to
match the documentation. Please keep this list in sorted order. */
- const char
- *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b",
- *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1",
- *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command",
- *dist = "distance", *dm = "dim", *f = "field", *failed="failed",
- *fs = "fsource", *han = "handler", *i = "i",
- *idy = "identity", *image = "image", *j = "j", *kind = "kind",
- *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a",
- *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask",
- *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number",
- *op = "operation", *ord = "order", *odd = "ordered", *p = "p",
- *p1 = "path1", *p2 = "path2", *pad = "pad", *pid = "pid", *pos = "pos",
- *pt = "pointer", *r = "r", *rd = "round",
- *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", *tm = "time",
- *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a",
- *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y",
- *z = "z";
+ const char *a
+ = "a",
+ *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", *bck = "back",
+ *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2",
+ *ca = "coarray", *com = "command", *dm = "dim", *f = "field",
+ *fs = "fsource", *han = "handler", *i = "i", *idy = "identity",
+ *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len",
+ *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
+ *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies = "ncopies",
+ *nm = "name", *num = "number", *op = "operation", *ord = "order",
+ *odd = "ordered", *p = "p", *p1 = "path1", *p2 = "path2", *pad = "pad",
+ *pid = "pid", *pos = "pos", *pt = "pointer", *r = "r", *rd = "round",
+ *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",
+ *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b",
+ *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z";
int di, dr, dd, dl, dc, dz, ii;
@@ -2265,9 +2263,11 @@ add_functions (void)
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
- add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, 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);
+ 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_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status,
@@ -2848,11 +2848,10 @@ add_functions (void)
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
- add_sym_2 ("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,
- dist, BT_INTEGER, di, OPTIONAL,
- failed, BT_LOGICAL, dl, OPTIONAL);
+ 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_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2018,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 3a702b32e10b..767792ceb232 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -132,7 +132,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 *, gfc_expr *);
+bool gfc_check_num_images (gfc_expr *);
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 *);
@@ -222,7 +222,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 *);
+bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
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 *);
@@ -328,7 +328,7 @@ 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_simplify_image_index (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 *);
@@ -383,7 +383,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_expr *gfc_simplify_num_images (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 *);
@@ -531,7 +531,7 @@ 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 *);
+void gfc_resolve_image_index (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 365e61bfaa31..3a105bc65f05 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -11427,47 +11427,48 @@ Fortran 95 and later
@table @asis
@item @emph{Synopsis}:
-@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)}
+@multitable @columnfractions .80
+@item @code{RESULT = NUM_IMAGES([TEAM])}
+@item @code{RESULT = NUM_IMAGES(TEAM_NUMBER)}
+@end multitable
@item @emph{Description}:
-Returns the number of images.
+Returns the number of images in the current team or the given team.
@item @emph{Class}:
Transformational function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
-@item @var{FAILED} @tab (optional, intent(in)) Scalar logical expression
+@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.
@end multitable
@item @emph{Return value}:
-Scalar default-kind integer. If @var{DISTANCE} is not present or has value 0,
-the number of images in the current team is returned. For values smaller or
-equal distance to the initial team, it returns the number of images index
-on the ancestor team that has a distance of @var{DISTANCE} from the invoking
-team. If @var{DISTANCE} is larger than the distance to the initial team, the
-number of images of the initial team is returned. If @var{FAILED} is not
present
-the total number of images is returned; if it has the value @code{.TRUE.},
-the number of failed images is returned, otherwise, the number of images that
-do have not the failed status.
+Scalar default-kind integer. Can be called without any arguments or a team
+type argument or a team_number argument.
@item @emph{Example}:
@smallexample
+use, intrinsic :: iso_fortran_env
INTEGER :: value[*]
INTEGER :: i
-value = THIS_IMAGE()
-SYNC ALL
-IF (THIS_IMAGE() == 1) THEN
- DO i = 1, NUM_IMAGES()
- WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
- END DO
-END IF
+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
@end smallexample
@item @emph{Standard}:
-Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument,
-Technical Specification (TS) 18508 or later
+Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument,
+Fortran 2018 and later.
@item @emph{See also}:
@ref{THIS_IMAGE}, @*
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index c286c2abe148..6930e2c3622b 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3229,7 +3229,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 *sub ATTRIBUTE_UNUSED,
+ gfc_expr *team_or_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 b94eb435798a..208251b5ec52 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -6729,7 +6729,7 @@ gfc_simplify_null (gfc_expr *mold)
gfc_expr *
-gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
+gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED)
{
gfc_expr *result;
@@ -6742,16 +6742,9 @@ gfc_simplify_num_images (gfc_expr *distance
ATTRIBUTE_UNUSED, gfc_expr *failed)
if (flag_coarray != GFC_FCOARRAY_SINGLE)
return NULL;
- if (failed && failed->expr_type != EXPR_CONSTANT)
- return NULL;
-
/* FIXME: gfc_current_locus is wrong. */
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
-
- if (failed && failed->value.logical != 0)
- mpz_set_si (result->value.integer, 0);
- else
mpz_set_si (result->value.integer, 1);
return result;
@@ -8927,7 +8920,8 @@ gfc_simplify_trim (gfc_expr *e)
gfc_expr *
-gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub,
+ gfc_expr *team_or_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 01c19956476e..f388ba5bc81d 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1184,7 +1184,9 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr,
tree *stat, tree *team,
gfc_se team_se;
gfc_init_se (&team_se, NULL);
gfc_conv_expr_reference (&team_se, team_e);
- *team = team_se.expr;
+ *team
+ = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
+ team_se.expr));
gfc_add_block_to_block (block, &team_se.pre);
gfc_add_block_to_block (block, &team_se.post);
}
@@ -1197,7 +1199,10 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr,
tree *stat, tree *team,
gfc_se team_se;
gfc_init_se (&team_se, NULL);
gfc_conv_expr_reference (&team_se, team_e);
- *team_no = team_se.expr;
+ *team_no = gfc_build_addr_expr (
+ NULL_TREE,
+ gfc_trans_force_lval (&team_se.pre,
+ fold_convert (integer_type_node, team_se.expr)));
gfc_add_block_to_block (block, &team_se.pre);
gfc_add_block_to_block (block, &team_se.post);
}
@@ -1790,13 +1795,13 @@ conv_caf_sendget (gfc_code *code)
++caf_call_cnt;
tmp = build_call_expr_loc (
- input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token,
+ input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
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, lhs_team_no, rhs_stat, rhs_team, rhs_team_no);
+ rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &lhs_se.post);
@@ -2112,8 +2117,8 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
static void
trans_image_index (gfc_se * se, gfc_expr *expr)
{
- tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
- tmp, invalid_bound;
+ tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
+ invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
gfc_se argse, subse;
int rank, corank, codim;
@@ -2137,6 +2142,22 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
subdesc = build_fold_indirect_ref_loc (input_location,
gfc_conv_descriptor_data_get (subse.expr));
+ if (expr->value.function.actual->next->next->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_descriptor (&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)));
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ }
+
/* Fortran 2008 does not require that the values remain in the cobounds,
thus we need explicitly check this - and return 0 if they are exceeded.
*/
@@ -2212,8 +2233,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
else
{
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
- integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ team, team_number);
num_images = fold_convert (type, tmp);
}
@@ -2232,32 +2252,26 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
static void
trans_num_images (gfc_se * se, gfc_expr *expr)
{
- tree tmp, distance, failed;
+ tree tmp, team = null_pointer_node, team_number = null_pointer_node;
gfc_se argse;
if (expr->value.function.actual->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 (&se->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);
- distance = fold_convert (integer_type_node, argse.expr);
}
- else
- distance = integer_zero_node;
- if (expr->value.function.actual->next->expr)
- {
- gfc_init_se (&argse, NULL);
- gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- failed = fold_convert (integer_type_node, argse.expr);
- }
- else
- failed = build_int_cst (integer_type_node, -1);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
- distance, failed);
+ team, team_number);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
}
@@ -2687,8 +2701,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type, tmp),
@@ -2703,8 +2716,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
{
/* ubound = lbound + num_images() - 1. */
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type, tmp),
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f128b4c843ba..11fc1a8ff064 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1337,8 +1337,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
tree cond2;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
- 2, integer_zero_node,
- build_int_cst (integer_type_node, -1));
+ 2, null_pointer_node, null_pointer_node);
cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
images2, tmp);
cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
diff --git a/gcc/testsuite/gfortran.dg/coarray_49.f90
b/gcc/testsuite/gfortran.dg/coarray_49.f90
index 370e3fd5847c..fd8549b32a84 100644
--- a/gcc/testsuite/gfortran.dg/coarray_49.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_49.f90
@@ -5,5 +5,5 @@
program p
integer :: x[*]
- print *, image_index (x, [1.0]) ! { dg-error "shall be INTEGER" }
+ print *, image_index (x, [1.0]) ! { dg-error "must be INTEGER" }
end
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90
b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90
index 299ea62b0939..2d8a39a9084b 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90
@@ -20,6 +20,6 @@ program test
call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3)
end program test
-! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc..,
_gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc..,
_gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 6\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4,
&stat2, errmesg2, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc..,
res, &stat3, errmesg3, 8\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90
b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90
index 8419cf9159d9..05a135012d8f 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90
@@ -33,6 +33,6 @@ contains
end function hc
end program test
-! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr,
4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1
"original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr,
4, _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 0, 6\\);" 1
"original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0,
4, &stat2, errmesg2, 0, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc,
1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
index a38c2307516f..7939a797501a 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
@@ -19,7 +19,7 @@ end
! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\*
restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\)
caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1
"original" } }
-! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]*
parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).?
\\+ -?\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]*
parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0B, 0B\\).?
\\+ -?\[0-9\]+\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image
\\(0B\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1
"original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
index 3b504f5d5686..31a7677ed0e1 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
@@ -19,7 +19,7 @@ end
! { dg-final { scan-tree-dump-times "bar \\(struct array02_real\\(kind=4\\) &
restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\)
caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1
"original" } }
-! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]*
parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).?
\\+ -?\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]*
parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0B,
0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image
\\(0B\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+,
caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data -
\\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
index 779b0567357f..5a609d8690f8 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
@@ -41,16 +41,12 @@ endif
associate(me => this_image())
end associate
k1 = num_images()
-k2 = num_images(6)
-k3 = num_images(distance=7)
-k4 = num_images(distance=8, failed=.true.)
-k5 = num_images(failed=.false.)
+k2 = num_images(team)
+k3 = num_images(-1)
end
! { dg-final { scan-tree-dump-times "j\[1-4\] = 1;" 4 "original" } }
! { dg-final { scan-tree-dump-times "A\\.\[0-9\]+\\\[2\\\] = \\\{1, 1\\\};" 4
"original" } }
-! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k4 = 0;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k5 = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump "k1 = 1;" "original" } }
+! { dg-final { scan-tree-dump "k2 = 1;" "original" } }
+! { dg-final { scan-tree-dump "k3 = 1;" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
index d977e21778c1..9713e3dcb8a2 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
@@ -42,18 +42,16 @@ if (j4 /= 1) then
endif
end associate
k1 = num_images()
-k2 = num_images(6)
-k3 = num_images(distance=7)
-k4 = num_images(distance=8, failed=.true.)
-k5 = num_images(failed=.false.)
+k2 = num_images(team)
+k3 = num_images(-1)
+k4 = num_images(1)
end
! { dg-final { scan-tree-dump "j1 = _gfortran_caf_this_image \\(0B\\);"
"original" } }
! { dg-final { scan-tree-dump "j3 = _gfortran_caf_this_image \\(team\\);"
"original" } }
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image
\\(team\\) \\+ -1;" 2 "original" } }
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image
\\(0B\\) \\+ -1;" 2 "original" } }
-! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0,
-1\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6,
-1\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7,
-1\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k4 = _gfortran_caf_num_images \\(8,
1\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "k5 = _gfortran_caf_num_images \\(0,
0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump "k1 = _gfortran_caf_num_images \\(0B, 0B\\);"
"original" } }
+! { dg-final { scan-tree-dump "k2 = _gfortran_caf_num_images \\(team, 0B\\);"
"original" } }
+! { dg-final { scan-tree-dump "k3 = _gfortran_caf_num_images \\(0B,
&D\\.\[0-9\]+\\);" "original" } }
+! { dg-final { scan-tree-dump "k4 = _gfortran_caf_num_images \\(0B,
&D\\.\[0-9\]+\\);" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
index d3464813f2b9..b8433b20538d 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
@@ -22,13 +22,10 @@ j4 = this_image(caf, 1, team) ! ok
j5 = this_image(caf, 1, team, 'baz') !{ dg-error "Too many arguments in call" }
j6 = this_image(dim=1, team=team, coarray=caf)
-!k1 = num_images()
-
-!k2 = num_images(6)
-
-!k3 = num_images(distance=7)
-
-!k4 = num_images(distance=8, failed=.true.)
-
-!k5 = num_images(failed=.false.)
+k1 = num_images() ! ok
+k2 = num_images(team) ! ok
+k3 = num_images(team, 2) !{ dg-error "Too many arguments in call to" }
+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" }
end
diff --git a/gcc/testsuite/gfortran.dg/num_images_1.f90
b/gcc/testsuite/gfortran.dg/num_images_1.f90
index dac34bafb4f1..e03857c04c3a 100644
--- a/gcc/testsuite/gfortran.dg/num_images_1.f90
+++ b/gcc/testsuite/gfortran.dg/num_images_1.f90
@@ -5,5 +5,5 @@
program foo
implicit none
integer k5
- k5 = num_images(failed=.false.) ! { dg-error "argument to NUM_IMAGES" }
+ k5 = num_images(failed=.false.) ! { dg-error "Cannot find keyword named
'failed' in call to 'num_images'" }
end program foo
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 97924b365566..2db8e3903822 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -92,7 +92,7 @@ void _gfortran_caf_init (int *, char ***);
void _gfortran_caf_finalize (void);
int _gfortran_caf_this_image (caf_team_t);
-int _gfortran_caf_num_images (int, int);
+int _gfortran_caf_num_images (caf_team_t, int32_t *);
void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *,
gfc_descriptor_t *, int *, char *, size_t);
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 2c277f0ead4b..a80fd966f441 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -202,8 +202,8 @@ _gfortran_caf_this_image (caf_team_t team)
}
int
-_gfortran_caf_num_images (int distance __attribute__ ((unused)),
- int failed __attribute__ ((unused)))
+_gfortran_caf_num_images (caf_team_t team __attribute__ ((unused)),
+ int32_t *team_number __attribute__ ((unused)))
{
return 1;
}
