https://gcc.gnu.org/g:9ebd7c3b978dba986c44cbc61f94cd97f381cc62
commit r16-77-g9ebd7c3b978dba986c44cbc61f94cd97f381cc62
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Tue Apr 1 12:17:43 2025 +0200
Fortran: Add team-support to this_image [PR87326]
This_image() no longer has a distance formal argument, but a team one.
The source of the distance argument could not be identified, i.e.
whether it came from a TS or standard draft. To implement only the
standard it is removed. Besides being defined, it was not used anyway.
PR fortran/87326
gcc/fortran/ChangeLog:
* check.cc (gfc_check_this_image): Check the three different
parameter lists possible for this_image and sort them correctly.
* gfortran.texi: Update documentation on this_image's API.
* intrinsic.cc (add_functions): Update this_image's signature.
(check_specific): Add specific check for this_image.
* intrinsic.h (gfc_check_this_image): Change to flexible
argument list.
* intrinsic.texi: Update documentation on this_image().
* iresolve.cc (gfc_resolve_this_image): Resolve the different
arguments.
* simplify.cc (gfc_simplify_this_image): Simplify the simplify
routine.
* trans-decl.cc (gfc_build_builtin_function_decls): Update
signature of this_image.
* trans-expr.cc (gfc_caf_get_image_index): Use correct signature
of this_image.
* trans-intrinsic.cc (trans_this_image): Adapt to correct
signature.
libgfortran/ChangeLog:
* caf/libcaf.h (_gfortran_caf_this_image): Correct prototype.
* caf/single.c (struct caf_single_team): Add new_index of image.
(_gfortran_caf_this_image): Return the image index in the given
team.
(_gfortran_caf_form_team): Set new_index in team structure.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray_10.f90: Update error messages.
* 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: Add more tests and
remove incorrect ones.
* gfortran.dg/coarray_this_image_2.f90: Test more features.
* gfortran.dg/coarray_this_image_3.f90: New test.
Diff:
---
gcc/fortran/check.cc | 122 ++++++++++++++-------
gcc/fortran/gfortran.texi | 16 +--
gcc/fortran/intrinsic.cc | 12 +-
gcc/fortran/intrinsic.h | 2 +-
gcc/fortran/intrinsic.texi | 30 +++--
gcc/fortran/iresolve.cc | 23 +++-
gcc/fortran/simplify.cc | 7 +-
gcc/fortran/trans-decl.cc | 6 +-
gcc/fortran/trans-expr.cc | 6 +-
gcc/fortran/trans-intrinsic.cc | 39 +++----
gcc/testsuite/gfortran.dg/coarray_10.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 | 49 ++++++++-
gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 | 52 ++++++++-
gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 | 34 ++++++
libgfortran/caf/libcaf.h | 2 +-
libgfortran/caf/single.c | 13 +--
18 files changed, 290 insertions(+), 129 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index a1c3de3e80dd..c27f653d3b06 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6665,75 +6665,115 @@ gfc_check_team_number (gfc_expr *team)
bool
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
+gfc_check_this_image (gfc_actual_arglist *args)
{
+ gfc_expr *coarray, *dim, *team, *cur;
+
+ coarray = dim = team = NULL;
+
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to
enable");
return false;
}
- if (coarray == NULL && dim == NULL && distance == NULL)
+ /* Shortcut when no arguments are given. */
+ if (!args->expr && !args->next->expr && !args->next->next->expr)
return true;
- if (dim != NULL && coarray == NULL)
- {
- gfc_error ("DIM argument without COARRAY argument not allowed for "
- "THIS_IMAGE intrinsic at %L", &dim->where);
- return false;
- }
+ cur = args->expr;
- if (distance && (coarray || dim))
+ if (cur)
{
- gfc_error ("The DISTANCE argument may not be specified together with the
"
- "COARRAY or DIM argument in intrinsic at %L",
- &distance->where);
- return false;
+ gfc_push_suppress_errors ();
+ if (coarray_check (cur, 0))
+ coarray = cur;
+ else if (scalar_check (cur, 2) && team_type_check (cur, 2))
+ team = cur;
+ else
+ {
+ gfc_pop_suppress_errors ();
+ gfc_error ("First argument of %<this_image%> intrinsic at %L must be "
+ "a coarray "
+ "variable or an object of type %<team_type%> from the "
+ "intrinsic module "
+ "%<ISO_FORTRAN_ENV%>",
+ &cur->where);
+ return false;
+ }
+ gfc_pop_suppress_errors ();
}
- /* Assume that we have "this_image (distance)". */
- if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
+ cur = args->next->expr;
+ if (cur)
{
- if (dim)
+ gfc_push_suppress_errors ();
+ if (dim_check (cur, 1, true) && cur->corank == 0)
+ dim = cur;
+ else if (scalar_check (cur, 2) && team_type_check (cur, 2))
{
- gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
- &coarray->where);
+ if (team)
+ {
+ gfc_pop_suppress_errors ();
+ goto team_type_error;
+ }
+ team = cur;
+ }
+ else
+ {
+ gfc_pop_suppress_errors ();
+ gfc_error ("Second argument of %<this_image%> intrinsic at %L must "
+ "be an %<INTEGER%> "
+ "typed scalar or an object of type %<team_type%> from the "
+ "intrinsic "
+ "module %<ISO_FORTRAN_ENV%>",
+ &cur->where);
return false;
}
- distance = coarray;
+ gfc_pop_suppress_errors ();
}
- if (distance)
+ cur = args->next->next->expr;
+ if (cur)
{
- if (!type_check (distance, 2, BT_INTEGER))
- return false;
-
- if (!nonnegative_check ("DISTANCE", distance))
- return false;
-
- if (!scalar_check (distance, 2))
- return false;
-
- if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to "
- "THIS_IMAGE at %L", &distance->where))
+ if (team_type_check (cur, 2) && scalar_check (cur, 2))
+ {
+ if (team)
+ goto team_type_error;
+ team = cur;
+ }
+ else
return false;
+ }
- return true;
+ if (dim != NULL && coarray == NULL)
+ {
+ gfc_error ("%<dim%> argument without %<coarray%> argument not allowed "
+ "for %<this_image%> intrinsic at %L",
+ &dim->where);
+ return false;
}
- if (!coarray_check (coarray, 0))
+ if (dim && !dim_corank_check (dim, coarray))
return false;
- if (dim != NULL)
- {
- if (!dim_check (dim, 1, false))
- return false;
-
- if (!dim_corank_check (dim, coarray))
- return false;
- }
+ if (team
+ && !gfc_notify_std (GFC_STD_F2018,
+ "%<team%> argument to %<this_image%> at %L",
+ &team->where))
+ return false;
+ args->expr = coarray;
+ args->next->expr = dim;
+ args->next->next->expr = team;
return true;
+
+team_type_error:
+ gfc_error (
+ "At most one argument of type %<team_type%> from the intrinsic module "
+ "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed",
+ &cur->where);
+ return false;
}
/* Calculate the sizes for transfer, used by gfc_check_transfer and also
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index a80963159919..33ac6d43ab86 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4300,21 +4300,23 @@ using the STOP and ERROR STOP statements; those use
different library calls.
@table @asis
@item @emph{Synopsis}:
-@code{int _gfortran_caf_this_image (int distance)}
+@code{int _gfortran_caf_this_image (caf_team_t team)}
@item @emph{Description}:
-This function returns the current image number, which is a positive number.
+Return the current image number in the @var{team}, or in the current team, if
+no @var{team} is given.
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{distance} @tab As specified for the @code{this_image} intrinsic
-in TS18508. Shall be a nonnegative number.
+@item @var{team} @tab intent(in), optional; The team this image's number is
+requested for. If null, the image number in the current team is returned.
@end multitable
@item @emph{Notes}:
-If the Fortran intrinsic @code{this_image} is invoked without an argument,
which
-is the only permitted form in Fortran 2008, GCC passes @code{0} as
-first argument.
+Available since Fortran 2008 without argument; Since Fortran 2018 with optional
+team argument. Fortran 2008 uses 0 as argument for team, which is permissible,
+because a team handle is always an opaque pointer, which as a special case can
+be null here.
@end table
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 7d459d0d84a2..ce586a20ad5e 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3338,10 +3338,11 @@ add_functions (void)
gfc_check_team_number, NULL, gfc_resolve_team_number,
team, BT_DERIVED, di, OPTIONAL);
- add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_this_image, gfc_simplify_this_image,
gfc_resolve_this_image,
- ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
- dist, BT_INTEGER, di, OPTIONAL);
+ add_sym_3red ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image,
+ gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL,
+ dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, team, BT_DERIVED,
+ di, OPTIONAL);
add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
@@ -4956,6 +4957,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr
*expr, int error_flag)
else if (specific->check.f3red == gfc_check_transf_bit_intrins)
/* Same as for PRODUCT and SUM, but different checks. */
t = gfc_check_transf_bit_intrins (*ap);
+ else if (specific->check.f3red == gfc_check_this_image)
+ /* May need to reassign arguments. */
+ t = gfc_check_this_image (*ap);
else
{
if (specific->check.f1 == NULL)
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index c177fcbc3df8..3a702b32e10b 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -234,7 +234,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr
*);
bool gfc_check_sleep_sub (gfc_expr *);
bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
-bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_this_image (gfc_actual_arglist *);
bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index cc01a9d8ded5..365e61bfaa31 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -14579,9 +14579,8 @@ Fortran 2018 and later.
@table @asis
@item @emph{Synopsis}:
@multitable @columnfractions .80
-@item @code{RESULT = THIS_IMAGE()}
-@item @code{RESULT = THIS_IMAGE(DISTANCE)}
-@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
+@item @code{RESULT = THIS_IMAGE([TEAM])}
+@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM][, TEAM])}
@end multitable
@item @emph{Description}:
@@ -14592,8 +14591,8 @@ Transformational function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
-(not permitted together with @var{COARRAY}).
+@item @var{TEAM} @tab (optional, intent(in)) The team for which the index of
+this image is desired. The current team is used, when no team is given.
@item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM}
present, required).
@item @var{DIM} @tab default integer scalar (optional). If present,
@@ -14602,16 +14601,16 @@ present, required).
@item @emph{Return value}:
Default integer. If @var{COARRAY} is not present, it is scalar; if
-@var{DISTANCE} is not present or has value 0, its value is the image index on
-the invoking image for the current team, for values smaller or equal
-distance to the initial team, it returns the image 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 image
-index of the initial team is returned. Otherwise when the @var{COARRAY} is
+@var{TEAM} is not present, its value is the image index on the invoking image
+for the current team; if @var{TEAM} is present, returns the image index of
+the invoking image as given to the @code{FORM TEAM (..., NEW_INDEX=..)} call,
+or a implementation specific unique number, when @code{NEW_INDEX=} was absent
+from @code{FORM TEAM}. Otherwise when the @var{COARRAY} is
present, if @var{DIM} is not present, a rank-1 array with corank elements is
returned, containing the cosubscripts for @var{COARRAY} specifying the invoking
-image. If @var{DIM} is present, a scalar is returned, with the value of
-the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}.
+image (in the team when @var{TEAM} is present). If @var{DIM} is present, a
+scalar is returned, with the value of the @var{DIM} element of
+@code{THIS_IMAGE(COARRAY)}.
@item @emph{Example}:
@smallexample
@@ -14626,13 +14625,12 @@ IF (THIS_IMAGE() == 1) THEN
END IF
! Check whether the current image is the initial image
-IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE())
+IF (THIS_IMAGE(GET_TEAM(INITIAL_TEAM)) /= THIS_IMAGE())
error stop "something is rotten here"
@end smallexample
@item @emph{Standard}:
-Fortran 2008 and later. With @var{DISTANCE} argument,
-Technical Specification (TS) 18508 or later
+Fortran 2008 and later. With @var{TEAM} argument, Fortran 2018 or later
@item @emph{See also}:
@ref{NUM_IMAGES}, @*
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 567bf528b2a4..c286c2abe148 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3271,20 +3271,33 @@ gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
}
void
-gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
- gfc_expr *distance ATTRIBUTE_UNUSED)
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim,
+ gfc_expr *team)
{
static char this_image[] = "__this_image";
- if (array && gfc_is_coarray (array))
- resolve_bound (f, array, dim, NULL, "__this_image", true);
+ if (coarray && dim)
+ resolve_bound (f, coarray, dim, NULL, this_image, true);
+ else if (coarray)
+ {
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = this_image;
+ if (f->shape && f->rank != 1)
+ gfc_free_shape (&f->shape, f->rank);
+ f->rank = 1;
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_ui (f->shape[0], coarray->corank);
+ }
else
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = this_image;
}
-}
+ if (team)
+ gfc_resolve_expr (team);
+}
void
gfc_resolve_time (gfc_expr *f)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6e773d1a3a14..b94eb435798a 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -9069,14 +9069,13 @@ gfc_simplify_image_status (gfc_expr *image, gfc_expr
*team ATTRIBUTE_UNUSED)
gfc_expr *
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
- gfc_expr *distance ATTRIBUTE_UNUSED)
+ gfc_expr *team ATTRIBUTE_UNUSED)
{
if (flag_coarray != GFC_FCOARRAY_SINGLE)
return NULL;
- /* If no coarray argument has been passed or when the first argument
- is actually a distance argument. */
- if (coarray == NULL || !gfc_is_coarray (coarray))
+ /* If no coarray argument has been passed. */
+ if (coarray == NULL)
{
gfc_expr *result;
/* FIXME: gfc_current_locus is wrong. */
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index a2905b666c7a..ee48a820f285 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4043,9 +4043,9 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
- gfor_fndecl_caf_this_image = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_this_image")), integer_type_node,
- 1, integer_type_node);
+ gfor_fndecl_caf_this_image = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_this_image")), ". r ", integer_type_node,
+ 1, pvoid_type_node);
gfor_fndecl_caf_num_images = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_num_images")), integer_type_node,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 276f325cc483..19e5669b9ee9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr
*e, tree desc)
gcc_assert (ref != NULL);
if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
- {
- return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image,
1,
- integer_zero_node);
- }
+ return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+ null_pointer_node);
img_idx = build_zero_cst (gfc_array_index_type);
extent = build_one_cst (gfc_array_index_type);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 2e314609b16e..01c19956476e 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1818,34 +1818,31 @@ static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
stmtblock_t loop;
- tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
- lbound, ubound, extent, ml;
+ tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
lbound,
+ ubound, extent, ml, team;
gfc_se argse;
int rank, corank;
- gfc_expr *distance = expr->value.function.actual->next->next->expr;
-
- if (expr->value.function.actual->expr
- && !gfc_is_coarray (expr->value.function.actual->expr))
- distance = expr->value.function.actual->expr;
/* The case -fcoarray=single is handled elsewhere. */
gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
+ /* Translate team, if present. */
+ if (expr->value.function.actual->next->next->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse,
expr->value.function.actual->next->next->expr);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ team = fold_convert (pvoid_type_node, argse.expr);
+ }
+ else
+ team = null_pointer_node;
+
/* Argument-free version: THIS_IMAGE(). */
- if (distance || expr->value.function.actual->expr == NULL)
+ if (expr->value.function.actual->expr == NULL)
{
- if (distance)
- {
- gfc_init_se (&argse, NULL);
- gfc_conv_expr_val (&argse, distance);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- tmp = fold_convert (integer_type_node, argse.expr);
- }
- else
- tmp = integer_zero_node;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- tmp);
+ team);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
tmp);
return;
@@ -1940,8 +1937,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
*/
/* this_image () - 1. */
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- integer_zero_node);
+ tmp
+ = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
team);
tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
fold_convert (type, tmp), build_int_cst (type, 1));
if (corank == 1)
diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90
b/gcc/testsuite/gfortran.dg/coarray_10.f90
index 53917b58ff3a..6f453d5dcc68 100644
--- a/gcc/testsuite/gfortran.dg/coarray_10.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_10.f90
@@ -21,7 +21,7 @@ subroutine this_image_check()
integer,save :: z(4)[*], i
j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" }
- j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" }
+ j = this_image(dim=3) ! { dg-error "'dim' argument without 'coarray'
argument" }
i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
i = image_index(z, 2) ! { dg-error "must be a rank one array" }
end subroutine this_image_check
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 63cca3e32c7a..a38c2307516f 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90
@@ -21,6 +21,6 @@ end
! { 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 "mylbound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image
\\(0\\);" 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" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 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 a27d74078333..3b504f5d5686 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90
@@ -21,6 +21,6 @@ end
! { 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 "mylbound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image
\\(0\\);" 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" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 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 1fe231888a4e..779b0567357f 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90
@@ -1,8 +1,45 @@
-! { dg-do compile }
-! { dg-options "-fdump-tree-original -fcoarray=single" }
+!{ dg-do run }
+!{ dg-options "-fdump-tree-original -fcoarray=single" }
!
-j1 = this_image(distance=4)
-j2 = this_image(5)
+
+use, intrinsic :: iso_fortran_env, only: team_type
+integer :: caf[2,*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1)
+j1 = this_image()
+if (j1 /= 1) then
+ print *, me, ":", j1
+ stop 1
+endif
+res = this_image(caf)
+if (any (res /= [1, 1])) then
+ print *, me, ":", res
+ stop 2
+endif
+j2 = this_image(caf, 1)
+if (j2 /= 1) then
+ print *, me, ":", j2
+ stop 3
+endif
+j3 = this_image(team)
+if (j3 /= MOD(this_image() + 43, num_images()) +1) then
+ print *, me, ":", j3
+ stop 4
+endif
+res = this_image(caf, team)
+if (any(res /= [1, 1])) then
+ print *, me, ":", res
+ stop 5
+endif
+j4 = this_image(caf, 1, team)
+if (j4 /= 1) then
+ print *, me, ":", j4
+ stop 6
+endif
+associate(me => this_image())
+end associate
k1 = num_images()
k2 = num_images(6)
k3 = num_images(distance=7)
@@ -10,8 +47,8 @@ k4 = num_images(distance=8, failed=.true.)
k5 = num_images(failed=.false.)
end
-! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } }
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
index 002c897ac8ee..d977e21778c1 100644
--- a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90
@@ -1,8 +1,46 @@
-! { dg-do compile }
-! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!{ dg-do run }
+!{ dg-additional-options "-fdump-tree-original -fcoarray=lib -lcaf_single" }
!
-j1 = this_image(distance=4)
-j2 = this_image(5)
+
+use, intrinsic :: iso_fortran_env, only: team_type
+integer :: caf[2,*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1)
+
+associate(me => this_image())
+j1 = this_image()
+if (j1 /= 1) then
+ print *, me, ":", j1
+ stop 1
+endif
+res = this_image(caf)
+if (any (res /= [1, 1])) then
+ print *, me, ":", res
+ stop 2
+endif
+j2 = this_image(caf, 1)
+if (j2 /= 1) then
+ print *, me, ":", j2
+ stop 3
+endif
+j3 = this_image(team)
+if (j3 /= MOD(this_image() + 43, num_images()) +1) then
+ print *, me, ":", j3
+ stop 4
+endif
+res = this_image(caf, team)
+if (any(res /= [1, 1])) then
+ print *, me, ":", res
+ stop 5
+endif
+j4 = this_image(caf, 1, team)
+if (j4 /= 1) then
+ print *, me, ":", j4
+ stop 6
+endif
+end associate
k1 = num_images()
k2 = num_images(6)
k3 = num_images(distance=7)
@@ -10,8 +48,10 @@ k4 = num_images(distance=8, failed=.true.)
k5 = num_images(failed=.false.)
end
-! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1
"original" } }
-! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1
"original" } }
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
new file mode 100644
index 000000000000..d3464813f2b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+
+
+use, intrinsic :: iso_fortran_env, only: team_type
+integer :: caf[*]
+integer, allocatable :: res(:)
+type(team_type) :: team
+
+j1 = this_image() ! ok
+j1 = this_image('bar') !{ dg-error "First argument of 'this_image'" }
+res = this_image(caf) ! ok
+res = this_image(caf, caf) !{ dg-error "Second argument of 'this_image'" }
+j2 = this_image(caf, 1) ! ok
+j3 = this_image(caf, 'foo') !{ dg-error "Second argument of 'this_image'" }
+j4 = this_image(caf, [1, 2]) !{ dg-error "Second argument of 'this_image'" }
+j5 = this_image(team) ! ok
+j6 = this_image(team, caf) !{ dg-error "Second argument of 'this_image'" }
+res = this_image(caf, team) ! ok
+res = this_image(caf, team, 'foo') !{ dg-error "shall be of type 'team_type'" }
+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.)
+end
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index e1853b77caf9..97924b365566 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -91,7 +91,7 @@ caf_static_t;
void _gfortran_caf_init (int *, char ***);
void _gfortran_caf_finalize (void);
-int _gfortran_caf_this_image (int);
+int _gfortran_caf_this_image (caf_team_t);
int _gfortran_caf_num_images (int, int);
void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *,
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 4b04e24321d2..2c277f0ead4b 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -54,6 +54,7 @@ struct caf_single_team
{
struct caf_single_team *parent;
int team_no;
+ int index;
struct coarray_allocated
{
struct coarray_allocated *next;
@@ -194,14 +195,12 @@ _gfortran_caf_finalize (void)
caf_teams_formed = NULL;
}
-
int
-_gfortran_caf_this_image (int distance __attribute__ ((unused)))
+_gfortran_caf_this_image (caf_team_t team)
{
- return 1;
+ return team ? ((caf_single_team_t) team)->index : 1;
}
-
int
_gfortran_caf_num_images (int distance __attribute__ ((unused)),
int failed __attribute__ ((unused)))
@@ -1006,9 +1005,8 @@ void _gfortran_caf_random_init (bool repeatable, bool
image_distinct)
}
void
-_gfortran_caf_form_team (int team_no, caf_team_t *team,
- int *new_index __attribute__ ((unused)), int *stat,
- char *errmsg __attribute__ ((unused)),
+_gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,
+ int *stat, char *errmsg __attribute__ ((unused)),
size_t errmsg_len __attribute__ ((unused)))
{
const char alloc_fail_msg[] = "Failed to allocate team";
@@ -1025,6 +1023,7 @@ _gfortran_caf_form_team (int team_no, caf_team_t *team,
t = *((caf_single_team_t *) team);
t->parent = caf_teams_formed;
t->team_no = team_no;
+ t->index = new_index ? *new_index : 1;
t->allocated = NULL;
caf_teams_formed = t;
}
