https://gcc.gnu.org/g:621fe931be1e0220854e4d3c49cf2ce05cf735f7
commit r16-76-g621fe931be1e0220854e4d3c49cf2ce05cf735f7
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Mon Apr 7 15:12:09 2025 +0200
Fortran: Update get_team, team_number and image_status to F2018 [PR88154,
PR88960, PR97210, PR103001]
Add functions get_team() and team_number() to comply with F2018
standard.
Update image_status() to comply with F2018 standard.
PR fortran/88154
PR fortran/88960
PR fortran/97210
PR fortran/103001
gcc/fortran/ChangeLog:
* check.cc (team_type_check): Check a type for being team_type
from the iso_fortran_env module.
(gfc_check_image_status): Use team_type check.
(gfc_check_get_team): Check for level argument.
(gfc_check_team_number): Use team_type check.
* expr.cc (gfc_check_assign): Add treatment for returning
team_type in caf-single mode.
* gfortran.texi: Add/Update documentation for get_team and
team_number API functions.
* intrinsic.cc (add_functions): Update get_team signature.
* intrinsic.h (gfc_resolve_get_team): Add prototype.
* intrinsic.texi: Add/Update documentation for get_team and
team_number Fortran functions.
* iresolve.cc (gfc_resolve_get_team): Resolve return type to be
of type team_type.
* iso-fortran-env.def: Update STAT_LOCK constants. They have
nothing to do with files. Add level constants for get_team.
* libgfortran.h: Add level and unlock_stat constants.
* simplify.cc (gfc_simplify_get_team): Simply to correct return
type team_type.
* trans-decl.cc (gfc_build_builtin_function_decls): Update
get_team and image_status API prototypes to correct signatures.
* trans-intrinsic.cc (conv_intrinsic_image_status): Translate
second parameter correctly.
(conv_intrinsic_team_number): Translate optional single team
argument correctly.
(gfc_conv_intrinsic_function): Add translation of get_team.
libgfortran/ChangeLog:
* caf/libcaf.h: Add constants for get_team's level argument and
update stat values for failed images.
(_gfortran_caf_team_number): Add prototype.
(_gfortran_caf_get_team): Same.
* caf/single.c (_gfortran_caf_team_number): Get the given team's
team number.
(_gfortran_caf_get_team): Get the current team or the team given
by level when the argument is present.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/image_status_1.f08: Correct check for
team_type.
* gfortran.dg/pr102458.f90: Adapt to multiple errors.
* gfortran.dg/coarray/get_team_1.f90: New test.
* gfortran.dg/team_get_1.f90: New test.
* gfortran.dg/team_number_1.f90: Correct Fortran syntax.
Diff:
---
gcc/fortran/check.cc | 65 +++++++-----
gcc/fortran/expr.cc | 8 +-
gcc/fortran/gfortran.texi | 50 +++++++++
gcc/fortran/intrinsic.cc | 8 +-
gcc/fortran/intrinsic.h | 2 +-
gcc/fortran/intrinsic.texi | 112 +++++++++++++++++++++
gcc/fortran/iresolve.cc | 22 +++-
gcc/fortran/iso-fortran-env.def | 22 ++--
gcc/fortran/libgfortran.h | 10 +-
gcc/fortran/simplify.cc | 6 +-
gcc/fortran/trans-decl.cc | 14 ++-
gcc/fortran/trans-intrinsic.cc | 21 ++--
gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 | 29 ++++++
.../gfortran.dg/coarray/image_status_1.f08 | 2 +-
gcc/testsuite/gfortran.dg/pr102458.f90 | 2 +-
gcc/testsuite/gfortran.dg/team_get_1.f90 | 27 +++++
gcc/testsuite/gfortran.dg/team_number_1.f90 | 6 +-
libgfortran/caf/libcaf.h | 13 ++-
libgfortran/caf/single.c | 26 +++++
19 files changed, 367 insertions(+), 78 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 00342787a518..a1c3de3e80dd 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1809,6 +1809,23 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom,
gfc_expr *stat)
return gfc_check_atomic (atom, 1, value, 0, stat, 2);
}
+bool
+team_type_check (gfc_expr *e, int n)
+{
+ if (e->ts.type != BT_DERIVED || !e->ts.u.derived
+ || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall be of type "
+ "%<team_type%> from the intrinsic module "
+ "%<ISO_FORTRAN_ENV%>",
+ gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
+ &e->where);
+ return false;
+ }
+
+ return true;
+}
bool
gfc_check_image_status (gfc_expr *image, gfc_expr *team)
@@ -1818,14 +1835,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
|| !positive_check (0, image))
return false;
- if (team)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
- &team->where);
- return false;
- }
- return true;
+ return !team || (scalar_check (team, 0) && team_type_check (team, 0));
}
@@ -1905,10 +1915,25 @@ gfc_check_get_team (gfc_expr *level)
{
if (level)
{
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &level->where);
- return false;
+ int l;
+
+ if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0))
+ return false;
+
+ /* When level is a constant, try to extract it. If not, the runtime has
+ to check. */
+ if (gfc_extract_int (level, &l, 0))
+ return true;
+
+ if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM)
+ {
+ gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of "
+ "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants "
+ "from the intrinsic module ISO_FORTRAN_ENV",
+ gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+ &level->where);
+ return false;
+ }
}
return true;
}
@@ -6635,21 +6660,7 @@ gfc_check_team_number (gfc_expr *team)
return false;
}
- if (team)
- {
- if (team->ts.type != BT_DERIVED
- || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
- || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
- {
- gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER "
- "shall be of type TEAM_TYPE", &team->where);
- return false;
- }
- }
- else
- return true;
-
- return true;
+ return !team || (scalar_check (team, 0) && team_type_check (team, 0));
}
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 0753667e061d..07e9bac37a1c 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3836,7 +3836,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue,
int conform,
if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return true;
- else
+ /* Prevent the following error message for caf-single mode, because there
+ are no teams in single mode and the simplify returns a null then. */
+ else if (!(flag_coarray == GFC_FCOARRAY_SINGLE
+ && rvalue->ts.type == BT_DERIVED
+ && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && rvalue->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_TEAM_TYPE))
{
gfc_error ("NULL appears on right-hand side in assignment at %L",
&rvalue->where);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index ff385671d214..a80963159919 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4234,6 +4234,8 @@ future implementation of teams. It is about to change
without further notice.
* _gfortran_caf_change_team:: Team activation function
* _gfortran_caf_end_team:: Team termination function
* _gfortran_caf_sync_team:: Synchronize all images of a given team
+* _gfortran_caf_get_team:: Get the opaque handle of the specified team
+* _gfortran_caf_team_number:: Get the unique id of the given team
@end menu
@@ -5786,6 +5788,54 @@ an error message; may be NULL.
@end table
+
+@node _gfortran_caf_get_team
+@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the
specified team
+@cindex Coarray, _gfortran_caf_get_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{caf_team_t _gfortran_caf_get_team (int32_t *level)}
+
+@item @emph{Description}:
+Get the current team, when @var{level} is null, or the team specified by
+@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or
+@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module. When
+being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then
+the initial team is returned.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{level} @tab intent(in) If set to one of the levels specified in
+the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given
+team. Values different from the allowed ones lead to a runtime error.
+@end multitable
+@end table
+
+
+
+@node _gfortran_caf_team_number
+@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the
given team
+@cindex Coarray, _gfortran_caf_team_number
+
+@table @asis
+@item @emph{Synopsis}:
+@code{int _gfortran_caf_team_number (caf_team_t team)}
+
+@item @emph{Description}:
+The team id given when forming the team @ref{_gfortran_caf_form_team} of the
+team specified by @var{team}, if given, or of the current team, if @var{team}
+is absent. It is a runtime error to specify a non-existing team.
+The team has to be formed, i.e., it is not necessary that it is changed
+into to get the team number. The initial team has the team number @code{-1}.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(in) The team for which the team id is desired.
+@end multitable
+@end table
+
+
@c Intrinsic Procedures
@c ---------------------------------------------------------------------
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 91f16c7f35f9..7d459d0d84a2 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -2112,10 +2112,10 @@ add_functions (void)
make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
- add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL,
- ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018,
- gfc_check_get_team, NULL, gfc_resolve_get_team,
- level, BT_INTEGER, di, OPTIONAL);
+ add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+ BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team,
+ gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di,
+ OPTIONAL);
add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 70e14c4098b1..c177fcbc3df8 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -479,6 +479,7 @@ void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *a);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
+void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
@@ -523,7 +524,6 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *);
void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
void gfc_resolve_getgid (gfc_expr *);
void gfc_resolve_getpid (gfc_expr *);
-void gfc_resolve_get_team (gfc_expr *, gfc_expr *);
void gfc_resolve_getuid (gfc_expr *);
void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index ad89064cb595..cc01a9d8ded5 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -170,6 +170,7 @@ Some basic guidelines for editing this document:
* @code{GETGID}: GETGID, Group ID function
* @code{GETLOG}: GETLOG, Get login name
* @code{GETPID}: GETPID, Process ID function
+* @code{GET_TEAM}: GET_TEAM, Get the handle of a team
* @code{GETUID}: GETUID, User ID function
* @code{GMTIME}: GMTIME, Convert time to GMT info
* @code{HOSTNM}: HOSTNM, Get system host name
@@ -311,6 +312,7 @@ Some basic guidelines for editing this document:
* @code{TAN}: TAN, Tangent function
* @code{TAND}: TAND, Tangent function, degrees
* @code{TANH}: TANH, Hyperbolic tangent function
+* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team
* @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image
* @code{TIME}: TIME, Time function
* @code{TIME8}: TIME8, Time function (64-bit)
@@ -7336,6 +7338,59 @@ GNU extension
+@node GET_TEAM
+@section @code{GET_TEAM} --- Get the handle of a team
+@fnindex GET_TEAM
+@cindex coarray, @code{GET_TEAM}
+@cindex images, get a handle to a team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{RESULT = GET_TEAM([LEVEL])}
+
+@item @emph{Description}:
+Returns the handle of the current team, if @var{LEVEL} is not given. Or the
+team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants
+@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the
+intrinsic module @code{ISO_FORTRAN_ENV}. Calling the function with
+@code{PARENT_TEAM} while being on the initial team, returns a handle to the
+initial team. This ensures that always a valid team is returned, given that
+team handles can neither be checked for validity nor compared with each other
+or null.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Return value}:
+An opaque handle of @code{TEAM_TYPE} from the intrinsic module
+@code{ISO_FORTRAN_ENV}.
+
+@item @emph{Example}:
+@smallexample
+program info
+ use, intrinsic :: iso_fortran_env
+ type(team_type) :: init, curr, par, nt
+
+ init = get_team()
+ curr = get_team(current_team) ! init equals curr here
+ form team(1, nt)
+ change team(nt)
+ curr = get_team() ! or get_team(current_team)
+ par = get_team(parent_team) ! par equals init here
+ end team
+end program info
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 or later
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @*
+@ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
@node GETUID
@section @code{GETUID} --- User ID function
@fnindex GETUID
@@ -14467,6 +14522,54 @@ Fortran 77 and later, for a complex argument Fortran
2008 or later
+@node TEAM_NUMBER
+@section @code{TEAM_NUMBER} --- Retrieve team id of given team
+@fnindex TEAM_NUMBER
+@cindex coarray, @code{TEAM_NUMBER}
+@cindex teams, index of given team
+
+@table @asis
+@item @emph{Synopsis}:
+@item @code{RESULT = TEAM_NUMBER([TEAM])}
+
+@item @emph{Description}:
+Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}.
+If @var{TEAM} is absent, returns the team number of the current team.
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which
+the number, aka id, is desired.
+@end multitable
+
+@item @emph{Return value}:
+Default integer. The id as given in a call @code{FORM TEAM}. Applying
+@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned.
+Returns the id of the current team, if @var{TEAM} is null.
+
+@item @emph{Example}:
+@smallexample
+use, intrinsic :: iso_fortran_env
+type(team_type) :: t
+
+print *, team_number() ! -1
+form team (99, t)
+print *, team_number(t) ! 99
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2018 and later.
+
+@item @emph{See also}:
+@ref{GET_TEAM}, @*
+@ref{TEAM_NUMBER}
+@end table
+
+
+
@node THIS_IMAGE
@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of
this image
@fnindex THIS_IMAGE
@@ -15354,12 +15457,18 @@ parameters of the @code{CHARACTER} type. (Fortran
2008 or later.)
@item @code{CHARACTER_STORAGE_SIZE}:
Size in bits of the character storage unit.
+@item @code{CURRENT_TEAM}:
+The argument to @ref{GET_TEAM} to retrieve a handle of the current team.
+
@item @code{ERROR_UNIT}:
Identifies the preconnected unit used for error reporting.
@item @code{FILE_STORAGE_SIZE}:
Size in bits of the file-storage unit.
+@item @code{INTIAL_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle of the initial team.
+
@item @code{INPUT_UNIT}:
Identifies the preconnected unit identified by the asterisk
(@code{*}) in @code{READ} statement.
@@ -15397,6 +15506,9 @@ parameters of the @code{LOGICAL} type. (Fortran 2008 or
later.)
Identifies the preconnected unit identified by the asterisk
(@code{*}) in @code{WRITE} statement.
+@item @code{PARENT_TEAM}:
+Argument to @ref{GET_TEAM} to retrieve a handle to the parent team.
+
@item @code{REAL32}, @code{REAL64}, @code{REAL128}:
Kind type parameters to specify a REAL type with a storage
size of 32, 64, and 128 bits. It is negative if a target platform
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 858ffb1daebf..567bf528b2a4 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3209,11 +3209,21 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level
ATTRIBUTE_UNUSED)
{
static char get_team[] = "_gfortran_caf_get_team";
f->rank = 0;
- f->ts.type = BT_INTEGER;
- f->ts.kind = gfc_default_integer_kind;
+ f->ts.type = BT_DERIVED;
+ gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived);
+ if (!f->ts.u.derived
+ || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV)
+ {
+ gfc_error (
+ "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV "
+ "to define its result type TEAM_TYPE",
+ &f->where);
+ f->ts.type = BT_UNKNOWN;
+ }
f->value.function.name = get_team;
-}
+ /* No requirements to resolve for level argument now. */
+}
/* Resolve image_index (...). */
@@ -3248,15 +3258,17 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team
ATTRIBUTE_UNUSED,
/* Resolve team_number (team). */
void
-gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED)
+gfc_resolve_team_number (gfc_expr *f, gfc_expr *team)
{
static char team_number[] = "_gfortran_caf_team_number";
f->rank = 0;
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = team_number;
-}
+ if (team)
+ gfc_resolve_expr (team);
+}
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index 970f09fddd3a..250a730e1bf5 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -83,17 +83,23 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \
gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \
gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \
GFC_STAT_LOCKED, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \
+NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \
"stat_locked_other_image", \
GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \
- GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \
- GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
-NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \
- GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \
+ GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \
+ GFC_STAT_FAILED_IMAGE, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \
+ GFC_STAT_UNLOCKED, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \
+ GFC_CAF_INITIAL_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \
+ GFC_CAF_PARENT_TEAM, GFC_STD_F2018)
+NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \
+ GFC_CAF_CURRENT_TEAM, GFC_STD_F2018)
/* The arguments to NAMED_KINDARRAY are:
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 956536538eef..9de5afb6c83e 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -154,10 +154,18 @@ typedef enum
GFC_STAT_LOCKED,
GFC_STAT_LOCKED_OTHER_IMAGE,
GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above.
*/
- GFC_STAT_FAILED_IMAGE = 6001
+ GFC_STAT_FAILED_IMAGE = 6001,
+ GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002
}
libgfortran_stat_codes;
+typedef enum
+{
+ GFC_CAF_INITIAL_TEAM = 0,
+ GFC_CAF_PARENT_TEAM,
+ GFC_CAF_CURRENT_TEAM
+} libgfortran_team_levels;
+
typedef enum
{
GFC_CAF_ATOMIC_ADD = 1,
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 92ab17b2b963..6e773d1a3a14 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -3133,8 +3133,10 @@ gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
gfc_expr *result;
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
- result->rank = 0;
+ result = gfc_get_null_expr (&gfc_current_locus);
+ result->ts.type = BT_DERIVED;
+ gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived);
+
return result;
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ae996a05f07e..a2905b666c7a 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4215,10 +4215,9 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3,
pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_get_team
- = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_get_team")),
- void_type_node, 1, integer_type_node);
+ gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1,
+ pint_type);
gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
@@ -4229,10 +4228,9 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("caf_team_number")), ". r ",
integer_type_node, 1, integer_type_node);
- gfor_fndecl_caf_image_status
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_image_status")), ". . r ",
- integer_type_node, 2, integer_type_node, ppvoid_type_node);
+ gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec
(
+ get_identifier (PREFIX ("caf_image_status")), ". r r ",
+ integer_type_node, 2, integer_type_node, ppvoid_type_node);
gfor_fndecl_caf_stopped_images
= gfc_build_library_function_decl_with_spec (
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index cab3ebc00086..2e314609b16e 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2072,7 +2072,8 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
- args[0], build_int_cst (integer_type_node, -1));
+ args[0],
+ num_args < 2 ? null_pointer_node : args[1]);
else
gcc_unreachable ();
@@ -2092,18 +2093,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
if (flag_coarray ==
GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
- {
- tree arg;
-
- arg = gfc_evaluate_now (args[0], &se->pre);
- tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- fold_convert (integer_type_node, arg),
- integer_one_node);
- tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
- tmp, integer_zero_node,
- build_int_cst (integer_type_node,
- GFC_STAT_STOPPED_IMAGE));
- }
+ tmp = gfc_evaluate_now (args[0], &se->pre);
else if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
// the value -1 represents that no team has been created yet
@@ -2111,10 +2101,10 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
}
else if (flag_coarray == GFC_FCOARRAY_LIB &&
expr->value.function.actual->expr)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
- args[0], build_int_cst (integer_type_node, -1));
+ args[0]);
else if (flag_coarray == GFC_FCOARRAY_LIB)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
- integer_zero_node, build_int_cst (integer_type_node, -1));
+ null_pointer_node);
else
gcc_unreachable ();
@@ -11475,6 +11465,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr *
expr)
case GFC_ISYM_GETGID:
case GFC_ISYM_GETPID:
case GFC_ISYM_GETUID:
+ case GFC_ISYM_GET_TEAM:
case GFC_ISYM_HOSTNM:
case GFC_ISYM_IERRNO:
case GFC_ISYM_IRAND:
diff --git a/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90
b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90
new file mode 100644
index 000000000000..f37d1c7f3795
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90
@@ -0,0 +1,29 @@
+!{ dg-do compile }
+
+! PR 97210
+! Tests get_team syntax
+
+ use iso_fortran_env
+ implicit none
+ type(team_type) :: team, ret
+ integer :: level
+
+ ret = get_team()
+ ret = get_team('abc') !{ dg-error "must be INTEGER" }
+ ret = get_team(level, 'abc') !{ dg-error "Too many arguments" }
+ ret = get_team([1,2]) !{ dg-error "must be a scalar" }
+ ret = get_team(team) !{ dg-error "must be INTEGER" }
+
+ ret = get_team(INITIAL_TEAM)
+ ret = get_team(CURRENT_TEAM)
+ ret = get_team(PARENT_TEAM)
+ ret = get_team(INITIAL_TEAM, CURRENT_TEAM) !{ dg-error "Too many arguments" }
+
+ level = INITIAL_TEAM
+ ret = get_team(level)
+ ret = get_team(99) !{ dg-error "specify one of the INITIAL_TEAM,
PARENT_TEAM" }
+ level = 99
+ ret = get_team(level)
+ level = get_team() !{ dg-error "Cannot convert TYPE\\(team_type\\)" }
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
index 098a2bb958e1..b7ec5a6a9c97 100644
--- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
+++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
@@ -18,7 +18,7 @@ program test_image_status_1
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
- isv = image_status(1, team=1) ! { dg-error "'team' argument of
'image_status' intrinsic at \\(1\\) not yet supported" }
+ isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
isv = image_status() ! { dg-error "Missing actual argument 'image'
in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image'
in call to 'image_status' at \\(1\\)" }
diff --git a/gcc/testsuite/gfortran.dg/pr102458.f90
b/gcc/testsuite/gfortran.dg/pr102458.f90
index 555e4978fdb1..7c13084acf48 100644
--- a/gcc/testsuite/gfortran.dg/pr102458.f90
+++ b/gcc/testsuite/gfortran.dg/pr102458.f90
@@ -9,7 +9,7 @@ end
program p
block
- integer :: a(get_team()) = 1 ! { dg-error "Automatic array" }
+ integer :: a(get_team()) = 1 ! { dg-error "Automatic array |
ISO_FORTRAN_ENV | must be of INTEGER" }
print *, a
end block
end
diff --git a/gcc/testsuite/gfortran.dg/team_get_1.f90
b/gcc/testsuite/gfortran.dg/team_get_1.f90
new file mode 100644
index 000000000000..fe00ce823712
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_get_1.f90
@@ -0,0 +1,27 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original" }
+
+! PR 87939
+! Tests get_team
+
+ use iso_fortran_env
+ implicit none
+ type(team_type) :: team, ret
+ integer :: new_team, level
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ ret = get_team()
+ ret = get_team(INITIAL_TEAM)
+ ret = get_team(PARENT_TEAM)
+ ret = get_team(CURRENT_TEAM)
+ level = INITIAL_TEAM
+ ret = get_team(level)
+
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(0B\\)" "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_get_team
\\(&C\.\[0-9\]+\\)" 3 "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(&level\\)" "original"
} }
diff --git a/gcc/testsuite/gfortran.dg/team_number_1.f90
b/gcc/testsuite/gfortran.dg/team_number_1.f90
index e44e17b644b2..f0ee7d1768da 100644
--- a/gcc/testsuite/gfortran.dg/team_number_1.f90
+++ b/gcc/testsuite/gfortran.dg/team_number_1.f90
@@ -1,13 +1,13 @@
! { dg-do run }
! { dg-options "-fcoarray=single" }
!
-! Tests if team_number intrinsic fucntion works
+! Tests if team_number intrinsic function works
!
use iso_fortran_env, only : team_type
implicit none
- type(team_type) team
+ type(team_type) :: team
integer, parameter :: standard_initial_value=-1
- integer new_team
+ integer :: new_team
if (team_number()/=standard_initial_value) STOP 1
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index a674a1929e53..e1853b77caf9 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -39,10 +39,19 @@ typedef enum
CAF_STAT_LOCKED,
CAF_STAT_LOCKED_OTHER_IMAGE,
CAF_STAT_STOPPED_IMAGE = 6000,
- CAF_STAT_FAILED_IMAGE = 6001
+ CAF_STAT_FAILED_IMAGE = 6001,
+ CAF_STAT_UNLOCKED_FAILED_IMAGE = 6002
}
caf_stat_codes_t;
+/* Definitions of the Fortran 2018 standard; need to kept in sync with
+ ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */
+typedef enum
+{
+ CAF_INITIAL_TEAM = 0,
+ CAF_PARENT_TEAM,
+ CAF_CURRENT_TEAM
+} caf_team_level_t;
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
@@ -178,5 +187,7 @@ void _gfortran_caf_form_team (int, caf_team_t *, int *, int
*, char *, size_t);
void _gfortran_caf_change_team (caf_team_t, int *, char *, size_t);
void _gfortran_caf_end_team (int *, char *, size_t);
void _gfortran_caf_sync_team (caf_team_t, int *, char *, size_t);
+int _gfortran_caf_team_number (caf_team_t);
+caf_team_t _gfortran_caf_get_team (int32_t *);
#endif /* LIBCAF_H */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index a705699bfa93..4b04e24321d2 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -1084,3 +1084,29 @@ _gfortran_caf_sync_team (caf_team_t team __attribute__
((unused)), int *stat,
if (stat)
*stat = 0;
}
+
+int
+_gfortran_caf_team_number (caf_team_t team)
+{
+ return ((caf_single_team_t) team)->team_no;
+}
+
+caf_team_t
+_gfortran_caf_get_team (int32_t *level)
+{
+ if (!level)
+ return caf_team_stack;
+
+ switch ((caf_team_level_t) *level)
+ {
+ case CAF_INITIAL_TEAM:
+ return caf_initial_team;
+ case CAF_PARENT_TEAM:
+ return caf_team_stack->parent ? caf_team_stack->parent : caf_team_stack;
+ case CAF_CURRENT_TEAM:
+ return caf_team_stack;
+ default:
+ caf_runtime_error ("Illegal value for GET_TEAM");
+ }
+ return NULL; /* To prevent any warnings. */
+}
