Hi all,
attached patch reworks (FORM|CHANGE|END|SYNC) TEAM to implement the Fortran
2018 as much as possible. This work has been done in sync with enhancing the
OpenCoarrays library. Because CHANGE TEAM has an association list very similar
to ASSOCIATE, the common code has been factored out to implement the DRY
principle.
Regtests ok on x86_64-pc-linux-gnu / F41. Ok for mainline?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From 64c951fd2f64f5d4407076532fd57e8370254826 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Mon, 7 Apr 2025 09:36:24 +0200
Subject: [PATCH 2/6] Fortran: Improve F2018 TEAM handling [PR87326, PR87556,
PR88254, PR103896]
Improve the implementation of F2018 TEAM handling routines. Add
runtime-functions to caf_single to allow testing.
PR fortran/87326
PR fortran/87556
PR fortran/88254
PR fortran/103796
gcc/fortran/ChangeLog:
* coarray.cc (split_expr_at_caf_ref): Treat polymorphic types
correctly. Ensure resolve of expression after coindex.
(create_allocated_callback): Fix parameter of allocated function
for coarrays.
(coindexed_expr_callback): Improve detection of coarrays in
allocated function.
* decl.cc (gfc_match_end): Add team block matching.
* dump-parse-tree.cc (show_code_node): Dump change team block as
such.
* frontend-passes.cc (gfc_code_walker): Recognice team block.
* gfortran.texi: Add documentation for team api functions.
* intrinsic.texi: Add documentation about team_type in
iso_fortran_env module.
* iso-fortran-env.def (team_type): Use helper to get pointer
kind.
* match.cc (gfc_match_associate): Factor out matching of
association list, because it is used in change team as well.
(check_coarray_assoc): Ensure, that the association is to a
coarray.
(match_association_list): Match a list of association either in
associate or in change team.
(gfc_match_form_team): Match form team correctly include
new_index.
(gfc_match_change_team): Match change team with association
list.
(gfc_match_end_team): Match end team including stat and errmsg.
(gfc_match_return): Prevent return from team block.
* parse.cc (decode_statement): Sort team block.
(next_statement): Same.
(check_statement_label): Same.
(accept_statement): Same.
(verify_st_order): Same.
(parse_associate): Renamed to move_associates_to_block...
(move_associates_to_block): ... to enable reuse for change team.
(parse_change_team): Parse it as block.
(parse_executable): Same.
* parse.h (enum gfc_compile_state): Add team block as compiler
state.
* resolve.cc (resolve_scalar_argument): New function to resolve
an argument to a statement as a scalar.
(resolve_form_team): Resolve its members.
(resolve_change_team): Same.
(resolve_branch): Prevent branch from jumping out of team block.
(check_team): Removed.
* trans-decl.cc (gfc_build_builtin_function_decls): Add stat and
errmsg to team API functions and update their arguments.
* trans-expr.cc (gfc_trans_subcomponent_assign): Also null the
token when moving memory or an allocated() will not detect a
free.
* trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote):
Adapt to signature change no longer a pointer-pointer.
* trans-stmt.cc (gfc_trans_form_team): Translate a form team
including new_index.
(gfc_trans_change_team): Translate a change team as a block.
libgfortran/ChangeLog:
* caf/libcaf.h: Remove commented block.
(_gfortran_caf_form_team): Allow for all relevant arguments.
(_gfortran_caf_change_team): Same.
(_gfortran_caf_end_team): Same.
(_gfortran_caf_sync_team): Same.
* caf/single.c (struct caf_single_team): Team handling
structures.
(_gfortran_caf_init): Initialize initial team.
(free_team_list): Free all teams and the memory they hold.
(_gfortran_caf_finalize): Free initial and sibling teams.
(_gfortran_caf_register): Add memory registered to current team.
(_gfortran_caf_deregister): Unregister memory from current team.
(_gfortran_caf_is_present_on_remote): Check token's memptr for
llocation. May have been deallocated by an end team.
(_gfortran_caf_form_team): Push a new team stub to the list.
(_gfortran_caf_change_team): Push a formed team on top of the
ctive teams stack.
(_gfortran_caf_end_team): End the active team, free all memory
allocated during its livespan.
(_gfortran_caf_sync_team): Take stat and errmsg into account.
gcc/testsuite/ChangeLog:
* gfortran.dg/team_change_2.f90: New test.
* gfortran.dg/team_change_3.f90: New test.
* gfortran.dg/team_end_2.f90: New test.
* gfortran.dg/team_end_3.f90: New test.
* gfortran.dg/team_form_2.f90: New test.
* gfortran.dg/team_form_3.f90: New test.
* gfortran.dg/team_sync_2.f90: New test.
---
gcc/fortran/coarray.cc | 12 +-
gcc/fortran/decl.cc | 20 +-
gcc/fortran/dump-parse-tree.cc | 30 ++-
gcc/fortran/frontend-passes.cc | 1 +
gcc/fortran/gfortran.texi | 146 +++++++++-
gcc/fortran/intrinsic.texi | 4 +
gcc/fortran/iso-fortran-env.def | 4 +-
gcc/fortran/match.cc | 280 +++++++++++++++++---
gcc/fortran/parse.cc | 143 ++++++----
gcc/fortran/parse.h | 2 +-
gcc/fortran/resolve.cc | 86 ++++--
gcc/fortran/trans-decl.cc | 24 +-
gcc/fortran/trans-expr.cc | 7 +-
gcc/fortran/trans-intrinsic.cc | 4 +-
gcc/fortran/trans-stmt.cc | 91 ++++---
gcc/testsuite/gfortran.dg/team_change_2.f90 | 86 ++++++
gcc/testsuite/gfortran.dg/team_change_3.f90 | 29 ++
gcc/testsuite/gfortran.dg/team_end_2.f90 | 33 +++
gcc/testsuite/gfortran.dg/team_end_3.f90 | 39 +++
gcc/testsuite/gfortran.dg/team_form_2.f90 | 27 ++
gcc/testsuite/gfortran.dg/team_form_3.f90 | 34 +++
gcc/testsuite/gfortran.dg/team_sync_2.f90 | 27 ++
libgfortran/caf/libcaf.h | 20 +-
libgfortran/caf/single.c | 173 +++++++++++-
24 files changed, 1115 insertions(+), 207 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/team_change_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_change_3.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_end_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_end_3.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_form_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_form_3.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_sync_2.f90
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index 70583254d0d..2f067f855e5 100644
--- a/gcc/fortran/coarray.cc
+++ b/gcc/fortran/coarray.cc
@@ -357,7 +357,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
gcc_assert (expr->expr_type == EXPR_VARIABLE);
caf_ts = &expr->symtree->n.sym->ts;
- if (!expr->symtree->n.sym->attr.codimension)
+ if (!(expr->symtree->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension
+ : expr->symtree->n.sym->attr.codimension))
{
/* The coarray is in some component. Find it. */
caf_ref = expr->ref;
@@ -432,6 +434,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
else if (base->ts.type == BT_CLASS)
convert_coarray_class_to_derived_type (base, ns);
+ memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec));
+ gfc_resolve_expr (*post_caf_ref_expr);
+ (*post_caf_ref_expr)->corank = 0;
gfc_expression_rank (*post_caf_ref_expr);
if (for_send)
gfc_expression_rank (expr);
@@ -1130,8 +1135,8 @@ create_allocated_callback (gfc_expr *expr)
// ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
base = post_caf_ref_expr->symtree->n.sym;
+ base->attr.pointer = !base->attr.dimension;
gfc_set_sym_referenced (base);
- gfc_commit_symbol (base);
*argptr = gfc_get_formal_arglist ();
(*argptr)->sym = base;
argptr = &(*argptr)->next;
@@ -1420,7 +1425,8 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
{
case GFC_ISYM_ALLOCATED:
if ((*e)->value.function.actual->expr
- && gfc_is_coindexed ((*e)->value.function.actual->expr))
+ && (gfc_is_coarray ((*e)->value.function.actual->expr)
+ || gfc_is_coindexed ((*e)->value.function.actual->expr)))
{
rewrite_caf_allocated (e);
*walk_subtrees = 0;
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index feb454ea5b3..69acd2da981 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -8459,6 +8459,7 @@ gfc_match_end (gfc_statement *st)
{
case COMP_ASSOCIATE:
case COMP_BLOCK:
+ case COMP_CHANGE_TEAM:
if (startswith (block_name, "block@"))
block_name = NULL;
break;
@@ -8515,7 +8516,7 @@ gfc_match_end (gfc_statement *st)
case COMP_SUBROUTINE:
*st = ST_END_SUBROUTINE;
if (!abbreviated_modproc_decl)
- target = " subroutine";
+ target = " subroutine";
else
target = " procedure";
eos_ok = !contained_procedure ();
@@ -8524,7 +8525,7 @@ gfc_match_end (gfc_statement *st)
case COMP_FUNCTION:
*st = ST_END_FUNCTION;
if (!abbreviated_modproc_decl)
- target = " function";
+ target = " function";
else
target = " procedure";
eos_ok = !contained_procedure ();
@@ -8646,6 +8647,12 @@ gfc_match_end (gfc_statement *st)
eos_ok = 0;
break;
+ case COMP_CHANGE_TEAM:
+ *st = ST_END_TEAM;
+ target = " team";
+ eos_ok = 0;
+ break;
+
default:
gfc_error ("Unexpected END statement at %C");
goto cleanup;
@@ -8683,14 +8690,19 @@ gfc_match_end (gfc_statement *st)
else
got_matching_end = true;
+ if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
+ /* Emit errors of stat and errmsg parsing now to finish the block and
+ continue analysis of compilation unit. */
+ gfc_error_check ();
+
old_loc = gfc_current_locus;
/* If we're at the end, make sure a block name wasn't required. */
if (gfc_match_eos () == MATCH_YES)
{
-
if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
&& *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
- && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
+ && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
+ && *st != ST_END_TEAM)
return MATCH_YES;
if (!block_name)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 4ace093738c..dd920f3ab08 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2769,17 +2769,21 @@ show_code_node (int level, gfc_code *c)
fputs ("FAIL IMAGE ", dumpfile);
break;
- case EXEC_CHANGE_TEAM:
- fputs ("CHANGE TEAM", dumpfile);
- break;
-
case EXEC_END_TEAM:
fputs ("END TEAM", dumpfile);
show_sync_stat (&c->ext.sync_stat);
break;
case EXEC_FORM_TEAM:
- fputs ("FORM TEAM", dumpfile);
+ fputs ("FORM TEAM ", dumpfile);
+ show_expr (c->expr1);
+ show_expr (c->expr2);
+ if (c->expr3)
+ {
+ fputs (" NEW_INDEX", dumpfile);
+ show_expr (c->expr3);
+ }
+ show_sync_stat (&c->ext.sync_stat);
break;
case EXEC_SYNC_TEAM:
@@ -2930,6 +2934,7 @@ show_code_node (int level, gfc_code *c)
fputs ("ENDIF", dumpfile);
break;
+ case EXEC_CHANGE_TEAM:
case EXEC_BLOCK:
{
const char *blocktype, *sname = NULL;
@@ -2945,17 +2950,23 @@ show_code_node (int level, gfc_code *c)
if (fcn && fcn->expr_type == EXPR_FUNCTION)
sname = fcn->value.function.actual->expr->symtree->n.sym->name;
}
+ else if (c->op == EXEC_CHANGE_TEAM)
+ blocktype = "CHANGE TEAM";
else if (c->ext.block.assoc)
blocktype = "ASSOCIATE";
else
blocktype = "BLOCK";
show_indent ();
fprintf (dumpfile, "%s ", blocktype);
+ if (c->op == EXEC_CHANGE_TEAM)
+ show_expr (c->expr1);
for (alist = c->ext.block.assoc; alist; alist = alist->next)
{
fprintf (dumpfile, " %s = ", sname ? sname : alist->name);
show_expr (alist->target);
}
+ if (c->op == EXEC_CHANGE_TEAM)
+ show_sync_stat (&c->ext.block.sync_stat);
++show_level;
ns = c->ext.block.ns;
@@ -2965,8 +2976,13 @@ show_code_node (int level, gfc_code *c)
gfc_current_ns = saved_ns;
show_code (show_level, ns->code);
--show_level;
- show_indent ();
- fprintf (dumpfile, "END %s ", blocktype);
+ if (c->op != EXEC_CHANGE_TEAM)
+ {
+ /* A CHANGE_TEAM is terminated by a END_TEAM, which have its own
+ stat and errmsg. Therefore, let it print itself. */
+ show_indent ();
+ fprintf (dumpfile, "END %s ", blocktype);
+ }
break;
}
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index ef9c80147cc..02a0a2326a6 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5340,6 +5340,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
{
case EXEC_BLOCK:
+ case EXEC_CHANGE_TEAM:
WALK_SUBCODE (co->ext.block.ns->code);
if (co->ext.block.assoc)
{
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 96321617308..3048e9b9d07 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4230,6 +4230,10 @@ future implementation of teams. It is about to change without further notice.
* _gfortran_caf_co_min:: Collective minimum reduction
* _gfortran_caf_co_sum:: Collective summing reduction
* _gfortran_caf_co_reduce:: Generic collective reduction
+* _gfortran_caf_form_team:: Team creation function
+* _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
@end menu
@@ -4705,9 +4709,9 @@ structure.
operation, i.e., zero on success and non-zero on error. When @code{NULL} and an
error occurs, then an error message is printed and the program is terminated.
@item @var{team} @tab intent(in) The opaque team handle as returned by
-@code{FORM TEAM}. Unused at the moment.
+@code{FORM TEAM}.
@item @var{team_number} @tab intent(in) The number of the team this access is
-to be part of. Unused at the moment.
+to be part of.
@end multitable
@item @emph{Notes}:
@@ -4806,9 +4810,9 @@ structure.
operation, i.e., zero on success and non-zero on error. When @code{NULL} and an
error occurs, then an error message is printed and the program is terminated.
@item @var{team} @tab intent(in) The opaque team handle as returned by
-@code{FORM TEAM}. Unused at the moment.
+@code{FORM TEAM}.
@item @var{team_number} @tab intent(in) The number of the team this access is
-to be part of. Unused at the moment.
+to be part of.
@end multitable
@item @emph{Notes}:
@@ -4906,13 +4910,13 @@ the operation on the sending side, i.e., zero on success and non-zero on error.
When @code{NULL} and an error occurs, then an error message is printed and the
program is terminated.
@item @var{dst_team} @tab intent(in) The opaque team handle as returned by
-@code{FORM TEAM}. Unused at the moment.
+@code{FORM TEAM}.
@item @var{dst_team_number} @tab intent(in) The number of the team this access
-is to be part of. Unused at the moment.
+is to be part of.
@item @var{src_team} @tab intent(in) The opaque team handle as returned by
-@code{FORM TEAM}. Unused at the moment.
+@code{FORM TEAM}.
@item @var{src_team_number} @tab intent(in) The number of the team this access
-is to be part of. Unused at the moment.
+is to be part of.
@end multitable
@item @emph{Notes}:
@@ -5656,6 +5660,132 @@ or an array descriptor.
@end table
+
+@node _gfortran_caf_form_team
+@subsection @code{_gfortran_caf_form_team} --- Team creation function
+@cindex Coarray, _gfortran_caf_form_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_form_team (int team_id, caf_team_t *team,
+int *new_index, int *stat, char *errmsg, size_t errmsg_len)}
+
+@item @emph{Description}:
+Create a team. All images giving the same @var{team_id} in a call to
+@code{FORM TEAM} will form a new team addressable by the opaque handle
+@var{team} which is of type @code{team_type} from the intrinsic module
+@ref{ISO_FORTRAN_ENV}. In the team the image gets the image index given by
+@var{new_index} if present. If @var{new_index} is absent, then an
+implementation specific index is assigned.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team_id} @tab intent(in) A unique id for each team to form. Images
+giving the same @var{team_id} in a call to @code{FORM TEAM} belong to the same
+team.
+@item @var{team} @tab intent(out) The opaque pointer to the newly formed team
+@item @var{new_index} @tab intent(in) If non-null gives the unique index of
+this image in the newly formed team. When no @var{new_index} is given, the
+caf-library is free to choose a unique index.
+@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out) When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg
+@end multitable
+
+@item @emph{Notes}:
+The id given in @var{team_id} has to be unique in all subsequent calls to
+@code{FORM TEAM} on the same image. That id is the same used in
+@code{TEAM_NUMBER=} of coarray indexes, which motivates the uniqueness.
+
+The index given in @var{new_index} needs to be unique among all members of
+team to create. Failing uniqueness may lead to misbehaviour, which depends
+on the caf-library's implementation. The library is free to implement
+checks for this, which imposes overhead and therefore may be avoided.
+@end table
+
+
+
+@node _gfortran_caf_change_team
+@subsection @code{_gfortran_caf_change_team} --- Team activation function
+@cindex Coarray, _gfortran_caf_change_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_change_team (caf_team_t team, int *stat, char *errmsg,
+size_t errmsg_len)}
+
+@item @emph{Description}:
+Actives the team given by @var{team}, which must be formed but not active
+yet. This routine starts a new epoch on the coarray memory pool. All
+coarrays registered from now on, will be freeed once the team is terminated.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(inout) The opaque pointer to an already formed
+team
+@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out) When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg
+@end multitable
+
+@item @emph{Notes}:
+When an error occurs and @var{stat} is non-null, it will be set. Nevertheless
+will the Fortran program continue with the first statement in the change team
+block.
+@end table
+
+
+
+@node _gfortran_caf_end_team
+@subsection @code{_gfortran_caf_end_team} --- Team termination function
+@cindex Coarray, _gfortran_caf_end_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)}
+
+@item @emph{Description}:
+Terminates the last team changed to. The coarray memory epoch is
+terminated and all coarrays allocated since the execution of @code{CHANGE TEAM}
+are freeed.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out) When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg
+@end multitable
+@end table
+
+
+
+@node _gfortran_caf_sync_team
+@subsection @code{_gfortran_caf_sync_team} --- Synchronize all images of a given team
+@cindex Coarray, _gfortran_caf_sync_team
+
+@table @asis
+@item @emph{Synopsis}:
+@code{void _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg,
+size_t errmsg_len)}
+
+@item @emph{Description}:
+Blocks execution of the image calling @code{SYNC TEAM} until all images of the
+team given by @var{team} have joined the synchronisation call.
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{team} @tab intent(in) The opaque pointer to an active team
+@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
+@item @var{errmsg} @tab intent(out) When an error occurs, this is set to
+an error message; may be NULL.
+@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg
+@end multitable
+@end table
+
+
@c Intrinsic Procedures
@c ---------------------------------------------------------------------
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 8c160e58b00..ad89064cb59 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -15445,6 +15445,10 @@ Derived type with private components to be use with the @code{LOCK} and
@code{UNLOCK} statement. A variable of its type has to be always declared
as coarray and may not appear in a variable-definition context.
(Fortran 2008 or later.)
+@item @code{TEAM_TYPE}:
+An opaque type for handling teams. Note that a variable of type
+@code{TEAM_TYPE} is not comparable with other variables of the same or other
+types nor with null.
@end table
The module also provides the following intrinsic procedures:
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index b8926f4df93..970f09fddd3 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/gcc/fortran/iso-fortran-env.def
@@ -134,9 +134,7 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \
: gfc_default_integer_kind, GFC_STD_F2018)
NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \
- flag_coarray == GFC_FCOARRAY_LIB
- ? get_int_kind_from_node (ptr_type_node)
- : gfc_default_integer_kind, GFC_STD_F2018)
+ get_int_kind_from_node (ptr_type_node), GFC_STD_F2018)
NAMED_INTCST (ISOFORTRANENV_LOGICAL8, "logical8", \
gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2023)
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4d77e094ab9..32da9d43532 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1966,29 +1966,29 @@ gfc_match_block (void)
return MATCH_YES;
}
-
-/* Match an ASSOCIATE statement. */
-
-match
-gfc_match_associate (void)
+bool
+check_coarray_assoc (const char *name, gfc_association_list *assoc)
{
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" associate") != MATCH_YES)
- return MATCH_NO;
-
- /* Match the association list. */
- if (gfc_match_char ('(') != MATCH_YES)
+ if (assoc->target->expr_type == EXPR_VARIABLE
+ && !strcmp (assoc->target->symtree->name, name))
{
- gfc_error ("Expected association list at %C");
- return MATCH_ERROR;
+ gfc_error ("Codimension decl name %qs in association at %L "
+ "must not be the same as a selector",
+ name, &assoc->where);
+ return false;
}
+ return true;
+}
+
+match
+match_association_list (bool for_change_team = false)
+{
new_st.ext.block.assoc = NULL;
while (true)
{
- gfc_association_list* newAssoc = gfc_get_association_list ();
- gfc_association_list* a;
+ gfc_association_list *newAssoc = gfc_get_association_list ();
+ gfc_association_list *a;
+ locus pre_name = gfc_current_locus;
/* Match the next association. */
if (gfc_match (" %n ", newAssoc->name) != MATCH_YES)
@@ -1998,7 +1998,7 @@ gfc_match_associate (void)
}
/* Required for an assumed rank target. */
- if (gfc_peek_char () == '(')
+ if (!for_change_team && gfc_peek_char () == '(')
{
newAssoc->ar = gfc_get_array_ref ();
if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES)
@@ -2012,26 +2012,53 @@ gfc_match_associate (void)
gfc_error_now ("The bounds remapping list at %C is an experimental "
"F202y feature. Use std=f202y to enable");
+ if (for_change_team && gfc_peek_char () == '[')
+ {
+ if (!newAssoc->ar)
+ newAssoc->ar = gfc_get_array_ref ();
+ if (gfc_match_array_spec (&newAssoc->ar->as, false, true)
+ == MATCH_ERROR)
+ goto assocListError;
+ }
+
/* Match the next association. */
if (gfc_match (" =>", newAssoc->name) != MATCH_YES)
{
- gfc_error ("Expected association at %C");
- goto assocListError;
+ if (for_change_team)
+ gfc_current_locus = pre_name;
+
+ free (newAssoc);
+ return MATCH_NO;
}
- if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+ if (!for_change_team)
{
- /* Have another go, allowing for procedure pointer selectors. */
- gfc_matching_procptr_assignment = 1;
if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
{
+ /* Have another go, allowing for procedure pointer selectors. */
+ gfc_matching_procptr_assignment = 1;
+ if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+ {
+ gfc_matching_procptr_assignment = 0;
+ gfc_error ("Invalid association target at %C");
+ goto assocListError;
+ }
gfc_matching_procptr_assignment = 0;
- gfc_error ("Invalid association target at %C");
+ }
+ newAssoc->where = gfc_current_locus;
+ }
+ else
+ {
+ newAssoc->where = gfc_current_locus;
+ /* F2018, C1116: A selector in a coarray-association shall be a named
+ coarray. */
+ if (gfc_match (" %v", &newAssoc->target) != MATCH_YES)
+ {
+ gfc_error ("Selector in coarray association as %C shall be a "
+ "named coarray");
goto assocListError;
}
- gfc_matching_procptr_assignment = 0;
}
- newAssoc->where = gfc_current_locus;
/* Check that the current name is not yet in the list. */
for (a = new_st.ext.block.assoc; a; a = a->next)
@@ -2042,6 +2069,35 @@ gfc_match_associate (void)
goto assocListError;
}
+ if (for_change_team)
+ {
+ /* F2018, C1113: In a change-team-stmt, a coarray-name in a
+ codimension-decl shall not be the same as a selector, or another
+ coarray-name, in that statement.
+ The latter is already checked for above. So check only the
+ former.
+ */
+ if (!check_coarray_assoc (newAssoc->name, newAssoc))
+ goto assocListError;
+
+ for (a = new_st.ext.block.assoc; a; a = a->next)
+ {
+ if (!check_coarray_assoc (newAssoc->name, a)
+ || !check_coarray_assoc (a->name, newAssoc))
+ goto assocListError;
+
+ /* F2018, C1115: No selector shall appear more than once in a
+ * given change-team-stmt. */
+ if (!strcmp (newAssoc->target->symtree->name,
+ a->target->symtree->name))
+ {
+ gfc_error ("Selector at %L duplicates selector at %L",
+ &newAssoc->target->where, &a->target->where);
+ goto assocListError;
+ }
+ }
+ }
+
/* The target expression must not be coindexed. */
if (gfc_is_coindexed (newAssoc->target))
{
@@ -2108,8 +2164,40 @@ gfc_match_associate (void)
assocListError:
free (newAssoc);
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+}
+
+/* Match an ASSOCIATE statement. */
+
+match
+gfc_match_associate (void)
+{
+ match m;
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" associate") != MATCH_YES)
+ return MATCH_NO;
+
+ /* Match the association list. */
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Expected association list at %C");
+ return MATCH_ERROR;
+ }
+
+ m = match_association_list ();
+ if (m == MATCH_ERROR)
+ goto error;
+ else if (m == MATCH_NO)
+ {
+ gfc_error ("Expected association at %C");
goto error;
}
+
if (gfc_match_char (')') != MATCH_YES)
{
/* This should never happen as we peek above. */
@@ -3914,7 +4002,9 @@ match
gfc_match_form_team (void)
{
match m;
- gfc_expr *teamid,*team;
+ gfc_expr *teamid, *team, *new_index;
+
+ teamid = team = new_index = NULL;
if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
return MATCH_ERROR;
@@ -3932,18 +4022,61 @@ gfc_match_form_team (void)
if (gfc_match ("%e", &team) != MATCH_YES)
goto syntax;
- m = gfc_match_char (')');
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index,
+ ST_FORM_TEAM);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ break;
+ }
+
+ if (m == MATCH_ERROR)
goto syntax;
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+
new_st.expr1 = teamid;
new_st.expr2 = team;
+ new_st.expr3 = new_index;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FORM_TEAM);
+cleanup:
+ gfc_free_expr (new_index);
+ gfc_free_expr (new_st.ext.sync_stat.stat);
+ gfc_free_expr (new_st.ext.sync_stat.errmsg);
+ new_st.ext.sync_stat = {NULL, NULL};
+
+ gfc_free_expr (team);
+ gfc_free_expr (teamid);
+
return MATCH_ERROR;
}
@@ -3953,7 +4086,13 @@ match
gfc_match_change_team (void)
{
match m;
- gfc_expr *team;
+ gfc_expr *team = NULL;
+
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" change% team") != MATCH_YES)
+ return MATCH_NO;
if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
return MATCH_ERROR;
@@ -3961,15 +4100,41 @@ gfc_match_change_team (void)
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
- new_st.op = EXEC_CHANGE_TEAM;
-
if (gfc_match ("%e", &team) != MATCH_YES)
goto syntax;
- m = gfc_match_char (')');
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ m = match_association_list (true);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ else if (m == MATCH_NO)
+ for (;;)
+ {
+ m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+
+ break;
+ }
+
+ if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
+done:
+
new_st.expr1 = team;
return MATCH_YES;
@@ -3977,20 +4142,46 @@ gfc_match_change_team (void)
syntax:
gfc_syntax_error (ST_CHANGE_TEAM);
+cleanup:
+ gfc_free_expr (new_st.ext.block.sync_stat.stat);
+ gfc_free_expr (new_st.ext.block.sync_stat.errmsg);
+ new_st.ext.block.sync_stat = {NULL, NULL};
+ gfc_free_association_list (new_st.ext.block.assoc);
+ new_st.ext.block.assoc = NULL;
+ gfc_free_expr (team);
+
return MATCH_ERROR;
}
-/* Match a END TEAM statement. */
+/* Match an END TEAM statement. */
match
gfc_match_end_team (void)
{
- if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C"))
- return MATCH_ERROR;
+ if (gfc_match_eos () == MATCH_YES)
+ goto done;
- if (gfc_match_char ('(') == MATCH_YES)
+ if (gfc_match_char ('(') != MATCH_YES)
+ /* There could be a team-construct-name following. Let caller decide
+ about error. */
+ return MATCH_NO;
+
+ for (;;)
+ {
+ if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+
+ break;
+ }
+
+ if (gfc_match_char (')') != MATCH_YES)
goto syntax;
+done:
+
new_st.op = EXEC_END_TEAM;
return MATCH_YES;
@@ -3998,6 +4189,14 @@ gfc_match_end_team (void)
syntax:
gfc_syntax_error (ST_END_TEAM);
+cleanup:
+ gfc_free_expr (new_st.ext.sync_stat.stat);
+ gfc_free_expr (new_st.ext.sync_stat.errmsg);
+ new_st.ext.sync_stat = {NULL, NULL};
+
+ /* Try to match the closing bracket to allow error recovery. */
+ gfc_match_char (')');
+
return MATCH_ERROR;
}
@@ -5358,6 +5557,15 @@ gfc_match_return (void)
return MATCH_ERROR;
}
+ if (gfc_find_state (COMP_CHANGE_TEAM))
+ {
+ /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM
+ construct. */
+ gfc_error (
+ "Image control statement RETURN at %C in CHANGE TEAM-END TEAM block");
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto done;
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a95bb62afb8..c47f705d9d3 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -488,6 +488,7 @@ decode_statement (void)
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_associate, ST_ASSOCIATE);
+ match (NULL, gfc_match_change_team, ST_CHANGE_TEAM);
match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
@@ -517,7 +518,6 @@ decode_statement (void)
case 'c':
match ("call", gfc_match_call, ST_CALL);
- match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM);
match ("close", gfc_match_close, ST_CLOSE);
match ("continue", gfc_match_continue, ST_CONTINUE);
match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
@@ -537,7 +537,6 @@ decode_statement (void)
case 'e':
match ("end file", gfc_match_endfile, ST_END_FILE);
- match ("end team", gfc_match_end_team, ST_END_TEAM);
match ("exit", gfc_match_exit, ST_EXIT);
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
@@ -1927,8 +1926,7 @@ next_statement (void)
case ST_OMP_INTEROP: \
case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
- case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
- case ST_END_TEAM: case ST_SYNC_TEAM: \
+ case ST_FORM_TEAM: case ST_SYNC_TEAM: \
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@@ -2032,7 +2030,8 @@ next_statement (void)
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
- case ST_END_BLOCK: case ST_END_ASSOCIATE
+ case ST_END_BLOCK: case ST_END_ASSOCIATE: \
+ case ST_END_TEAM
/* Push a new state onto the stack. */
@@ -2164,6 +2163,7 @@ check_statement_label (gfc_statement st)
case ST_END_CRITICAL:
case ST_END_BLOCK:
case ST_END_ASSOCIATE:
+ case ST_END_TEAM:
case_executable:
case_exec_markers:
if (st == ST_ENDDO || st == ST_CONTINUE)
@@ -3199,6 +3199,8 @@ accept_statement (gfc_statement st)
case ST_ENTRY:
case ST_OMP_METADIRECTIVE:
case ST_OMP_BEGIN_METADIRECTIVE:
+ case ST_CHANGE_TEAM:
+ case ST_END_TEAM:
case_executable:
case_exec_markers:
add_statement ();
@@ -3383,6 +3385,8 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
goto order;
break;
+ case ST_CHANGE_TEAM:
+ case ST_END_TEAM:
case_executable:
case_exec_markers:
if (p->state < ORDER_EXEC)
@@ -5238,30 +5242,12 @@ parse_block_construct (void)
pop_state ();
}
-
-/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
- behind the scenes with compiler-generated variables. */
-
static void
-parse_associate (void)
+move_associates_to_block ()
{
- gfc_namespace* my_ns;
- gfc_state_data s;
- gfc_statement st;
- gfc_association_list* a;
+ gfc_association_list *a;
gfc_array_spec *as;
- gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
-
- my_ns = gfc_build_block_ns (gfc_current_ns);
-
- new_st.op = EXEC_BLOCK;
- new_st.ext.block.ns = my_ns;
- gcc_assert (new_st.ext.block.assoc);
-
- /* Add all associate-names as BLOCK variables. Creating them is enough
- for now, they'll get their values during trans-* phase. */
- gfc_current_ns = my_ns;
for (a = new_st.ext.block.assoc; a; a = a->next)
{
gfc_symbol *sym, *tsym;
@@ -5298,26 +5284,23 @@ parse_associate (void)
/* Donât share the character length information between associate
variable and target if the length is not a compile-time constant,
- as we donât want to touch some other character length variable when
- we try to initialize the associate variableâs character length
- variable.
- We do it here rather than later so that expressions referencing the
- associate variable will automatically have the correctly setup length
- information. If we did it at resolution stage the expressions would
- use the original length information, and the variable a new different
- one, but only the latter one would be correctly initialized at
- translation stage, and the former one would need some additional setup
- there. */
- if (sym->ts.type == BT_CHARACTER
- && sym->ts.u.cl
+ as we donât want to touch some other character length variable
+ when we try to initialize the associate variableâs character
+ length variable. We do it here rather than later so that expressions
+ referencing the associate variable will automatically have the
+ correctly setup length information. If we did it at resolution stage
+ the expressions would use the original length information, and the
+ variable a new different one, but only the latter one would be
+ correctly initialized at translation stage, and the former one would
+ need some additional setup there. */
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
&& !(sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
/* If the function has been parsed, go straight to the result to
obtain the expression rank. */
- if (target->expr_type == EXPR_FUNCTION
- && target->symtree
+ if (target->expr_type == EXPR_FUNCTION && target->symtree
&& target->symtree->n.sym)
{
tsym = target->symtree->n.sym;
@@ -5344,8 +5327,7 @@ parse_associate (void)
by calling gfc_resolve_expr because the context is unavailable.
However, the references can be resolved and the rank of the target
expression set. */
- if (!sym->assoc->inferred_type
- && target->ref && gfc_resolve_ref (target)
+ if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target)
&& target->expr_type != EXPR_ARRAY
&& target->expr_type != EXPR_COMPCALL)
gfc_expression_rank (target);
@@ -5353,13 +5335,12 @@ parse_associate (void)
/* Determine whether or not function expressions with unknown type are
structure constructors. If so, the function result can be converted
to be a derived type. */
- if (target->expr_type == EXPR_FUNCTION
- && target->ts.type == BT_UNKNOWN)
+ if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
{
gfc_symbol *derived;
/* The derived type has a leading uppercase character. */
gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
- my_ns->parent, 1, &derived);
+ gfc_current_ns->parent, 1, &derived);
if (derived && derived->attr.flavor == FL_DERIVED)
{
sym->ts.type = BT_DERIVED;
@@ -5394,7 +5375,7 @@ parse_associate (void)
attr.codimension = as->corank ? 1 : 0;
sym->assoc->variable = true;
}
- else if (rank || corank)
+ else if (rank || corank)
{
as = gfc_get_array_spec ();
as->type = AS_DEFERRED;
@@ -5449,6 +5430,30 @@ parse_associate (void)
}
gfc_commit_symbols ();
}
+}
+
+/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
+ behind the scenes with compiler-generated variables. */
+
+static void
+parse_associate (void)
+{
+ gfc_namespace* my_ns;
+ gfc_state_data s;
+ gfc_statement st;
+
+ gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
+
+ my_ns = gfc_build_block_ns (gfc_current_ns);
+
+ new_st.op = EXEC_BLOCK;
+ new_st.ext.block.ns = my_ns;
+ gcc_assert (new_st.ext.block.assoc);
+
+ /* Add all associate-names as BLOCK variables. Creating them is enough
+ for now, they'll get their values during trans-* phase. */
+ gfc_current_ns = my_ns;
+ move_associates_to_block ();
accept_statement (ST_ASSOCIATE);
push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
@@ -5474,6 +5479,49 @@ loop:
pop_state ();
}
+static void
+parse_change_team (void)
+{
+ gfc_namespace *my_ns;
+ gfc_state_data s;
+ gfc_statement st;
+
+ gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
+
+ my_ns = gfc_build_block_ns (gfc_current_ns);
+
+ new_st.op = EXEC_CHANGE_TEAM;
+ new_st.ext.block.ns = my_ns;
+
+ /* Add all associate-names as BLOCK variables. Creating them is enough
+ for now, they'll get their values during trans-* phase. */
+ gfc_current_ns = my_ns;
+ if (new_st.ext.block.assoc)
+ move_associates_to_block ();
+
+ accept_statement (ST_CHANGE_TEAM);
+ push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
+
+loop:
+ st = parse_executable (ST_NONE);
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+
+ case_end:
+ accept_statement (st);
+ my_ns->code = gfc_state_stack->head;
+ break;
+
+ default:
+ unexpected_statement (st);
+ goto loop;
+ }
+
+ gfc_current_ns = gfc_current_ns->parent;
+ pop_state ();
+}
/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
handled inside of parse_executable(), because they aren't really
@@ -6576,6 +6624,7 @@ parse_executable (gfc_statement st)
case ST_STOP:
case ST_ERROR_STOP:
case ST_END_SUBROUTINE:
+ case ST_END_TEAM:
case ST_DO:
case ST_FORALL:
@@ -6615,6 +6664,10 @@ parse_executable (gfc_statement st)
parse_associate ();
break;
+ case ST_CHANGE_TEAM:
+ parse_change_team ();
+ break;
+
case ST_IF_BLOCK:
parse_if_block ();
break;
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 722e94cef54..7bf0fa497e9 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -32,7 +32,7 @@ enum gfc_compile_state
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL,
COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK,
- COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE
+ COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE, COMP_CHANGE_TEAM
};
/* Stack element for the current compilation state. These structures
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e69905ae1f7..f4e399dd478 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11483,6 +11483,62 @@ gfc_resolve_sync_stat (struct sync_stat *sync_stat)
gfc_default_character_kind,
sync_stat->errmsg);
}
+
+static void
+resolve_scalar_argument (const char *name, bt exp_type, int exp_kind,
+ gfc_expr *e)
+{
+ gfc_resolve_expr (e);
+ if (e
+ && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0))
+ gfc_error ("%s argument at %L must be a scalar %s of at least kind %d",
+ name, &e->where, gfc_basic_typename (exp_type), exp_kind);
+}
+
+static void
+resolve_form_team (gfc_code *code)
+{
+ resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind,
+ code->expr1);
+ resolve_team_argument (code->expr2);
+ resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind,
+ code->expr3);
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
+
+static void resolve_block_construct (gfc_code *);
+
+static void
+resolve_change_team (gfc_code *code)
+{
+ resolve_team_argument (code->expr1);
+ gfc_resolve_sync_stat (&code->ext.block.sync_stat);
+ resolve_block_construct (code);
+ /* Map the coarray bounds as selected. */
+ for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next)
+ if (a->ar)
+ {
+ gfc_array_spec *src = a->ar->as, *dst;
+ if (a->st->n.sym->ts.type == BT_CLASS)
+ dst = CLASS_DATA (a->st->n.sym)->as;
+ else
+ dst = a->st->n.sym->as;
+ dst->corank = src->corank;
+ dst->cotype = src->cotype;
+ for (int i = 0; i < src->corank; ++i)
+ {
+ dst->lower[dst->rank + i] = src->lower[i];
+ dst->upper[dst->rank + i] = src->upper[i];
+ src->lower[i] = src->upper[i] = nullptr;
+ }
+ gfc_free_array_spec (src);
+ free (a->ar);
+ a->ar = nullptr;
+ dst->resolved = false;
+ gfc_resolve_array_spec (dst, 0);
+ }
+}
+
static void
resolve_sync_team (gfc_code *code)
{
@@ -11653,6 +11709,11 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
&& bitmap_bit_p (stack->reachable_labels, label->value))
gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
"for label at %L", &code->loc, &label->where);
+ else if (stack->current->op == EXEC_CHANGE_TEAM
+ && bitmap_bit_p (stack->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct "
+ "for label at %L",
+ &code->loc, &label->where);
}
return;
@@ -13289,23 +13350,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns)
}
-static bool
-check_team (gfc_expr *team, const char *intrinsic)
-{
- if (team->rank != 0
- || 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 to %qs at %L must be a scalar expression "
- "of type TEAM_TYPE", intrinsic, &team->where);
- return false;
- }
-
- return true;
-}
-
-
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@@ -13494,15 +13538,11 @@ start:
break;
case EXEC_FORM_TEAM:
- if (code->expr1 != NULL
- && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank))
- gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be "
- "a scalar INTEGER", &code->expr1->where);
- check_team (code->expr2, "FORM TEAM");
+ resolve_form_team (code);
break;
case EXEC_CHANGE_TEAM:
- check_team (code->expr1, "CHANGE TEAM");
+ resolve_change_team (code);
break;
case EXEC_END_TEAM:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 96c4ba9d6c3..36c4a77f4e9 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4201,21 +4201,19 @@ gfc_build_builtin_function_decls (void)
void_type_node, 3, pvoid_type_node, ppvoid_type_node,
integer_type_node);
- gfor_fndecl_caf_form_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_form_team")), ". . W . ",
- void_type_node, 3, integer_type_node, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_form_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_form_team")), ". r w r w w w ",
+ void_type_node, 6, integer_type_node, ppvoid_type_node, pint_type,
+ pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_change_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_change_team")), ". w . ",
- void_type_node, 2, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_change_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_change_team")), ". r w w w ",
+ void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node,
+ size_type_node);
- gfor_fndecl_caf_end_team
- = gfc_build_library_function_decl (
- get_identifier (PREFIX("caf_end_team")), void_type_node, 0);
+ gfor_fndecl_caf_end_team = gfc_build_library_function_decl_with_spec (
+ 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 (
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 62dd38d6f9d..276f325cc48 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9836,7 +9836,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
&& !cm->attr.proc_pointer)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ {
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
+ gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
+ null_pointer_node);
+ }
else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 16ade8d4d55..cab3ebc0008 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1379,9 +1379,9 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
present_fn = e->value.function.actual->next->next->expr;
add_data_sym = present_fn->symtree->n.sym->formal->sym;
- fn_index = conv_caf_func_index (&se->pre, gfc_current_ns,
+ fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
"__caf_present_on_remote_fn_index_%d", hash);
- add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns,
+ add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
"__caf_present_on_remote_add_data_%d",
add_data_sym, &add_data_size);
++caf_call_cnt;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index cc3c344fd5f..1b7dccd3e35 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -792,38 +792,42 @@ gfc_trans_form_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- gfc_se se;
- gfc_se argse1, argse2;
- tree team_id, team_type, tmp;
+ gfc_se se, argse;
+ tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
gfc_init_se (&se, NULL);
- gfc_init_se (&argse1, NULL);
- gfc_init_se (&argse2, NULL);
- gfc_start_block (&se.pre);
+ gfc_init_se (&argse, NULL);
- gfc_conv_expr_val (&argse1, code->expr1);
- gfc_conv_expr_val (&argse2, code->expr2);
- team_id = fold_convert (integer_type_node, argse1.expr);
- team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_id = fold_convert (integer_type_node, argse.expr);
+ gfc_conv_expr_reference (&argse, code->expr2);
+ team_type = argse.expr;
- gfc_add_block_to_block (&se.pre, &argse1.pre);
- gfc_add_block_to_block (&se.pre, &argse2.pre);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_form_team, 3,
- team_id, team_type,
- integer_zero_node);
+ /* NEW_INDEX=. */
+ if (code->expr3)
+ {
+ gfc_conv_expr_reference (&argse, code->expr3);
+ new_index = argse.expr;
+ }
+ else
+ new_index = null_pointer_node;
+
+ gfc_add_block_to_block (&se.post, &argse.post);
+
+ gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+ &errmsg_len);
+
+ gfc_add_block_to_block (&se.pre, &argse.pre);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6,
+ team_id, team_type, new_index, stat, errmsg,
+ errmsg_len);
gfc_add_expr_to_block (&se.pre, tmp);
- gfc_add_block_to_block (&se.pre, &argse1.post);
- gfc_add_block_to_block (&se.pre, &argse2.post);
+ gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
- }
+ }
else
- {
- const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
- gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
- tree tmp = gfc_get_symbol_decl (exsym);
- return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
- }
+ return trans_exit ();
}
/* Translate the CHANGE TEAM statement. */
@@ -833,27 +837,30 @@ gfc_trans_change_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- gfc_se argse;
- tree team_type, tmp;
+ stmtblock_t block;
+ gfc_se se;
+ tree team_type, stat, errmsg, errmsg_len, tmp;
- gfc_init_se (&argse, NULL);
- gfc_conv_expr_val (&argse, code->expr1);
- team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&block);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_change_team, 2, team_type,
- integer_zero_node);
- gfc_add_expr_to_block (&argse.pre, tmp);
- gfc_add_block_to_block (&argse.pre, &argse.post);
- return gfc_finish_block (&argse.pre);
+ gfc_conv_expr_val (&se, code->expr1);
+ team_type = se.expr;
+
+ gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
+ &errmsg_len);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
+ team_type, stat, errmsg, errmsg_len);
+
+ gfc_add_expr_to_block (&se.pre, tmp);
+ gfc_add_block_to_block (&se.pre, &se.post);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
+ return gfc_finish_block (&block);
}
else
- {
- const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
- gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
- tree tmp = gfc_get_symbol_decl (exsym);
- return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
- }
+ return trans_exit ();
}
/* Translate the END TEAM statement. */
diff --git a/gcc/testsuite/gfortran.dg/team_change_2.f90 b/gcc/testsuite/gfortran.dg/team_change_2.f90
new file mode 100644
index 00000000000..00cc489bf1f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_change_2.f90
@@ -0,0 +1,86 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests change team syntax
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+ integer :: new_team, istat
+ character(len=30) :: err
+ integer :: caf[*], caf2[*]
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ change team !{ dg-error "Syntax error in CHANGE TEAM statement" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ change team (err) !{ dg-error "must be a scalar expression of type TEAM_TYPE" }
+ continue
+ end team
+
+ change team (team, stat=err) !{ dg-error "must be a scalar INTEGER" }
+ continue
+ end team
+
+ change team (team, stat=istat, stat=istat) !{ dg-error "Duplicate STAT" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ change team (team, stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" }
+ continue
+ end team
+
+ change team (team, stat=istat, errmsg=str, errmsg=str) !{ dg-error "Duplicate ERRMSG" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+1234 if (istat /= 0) stop 1 !{ dg-error "leaves CHANGE TEAM" }
+
+ change team (team)
+ go to 1234 !{ dg-error "leaves CHANGE TEAM" }
+ end team
+
+ call foo(team)
+
+ ! F2018, C1113
+ change team (team, caf[3,*] => caf) !{ dg-error "Codimension decl name" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ change team (team, c[3,*] => caf, c => caf2) !{ dg-error "Duplicate name" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ change team (team, c[3,*] => caf, caf => caf2) !{ dg-error "Codimension decl name" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ change team (team, caf2[3,*] => caf, c => caf2) !{ dg-error "Codimension decl name" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ ! F2018, C1114
+ change team (team, c => [caf, caf2]) !{ dg-error "a named coarray" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+ ! F2018, C1115
+ change team (team, c => caf, c2 => caf) !{ dg-error "duplicates selector at" }
+ continue
+ end team !{ dg-error "Expecting END PROGRAM statement" }
+
+contains
+ subroutine foo(team)
+ type(team_type) :: team
+
+ change team (team)
+ return !{ dg-error "Image control statement" }
+ end team
+ end subroutine
+end
+
diff --git a/gcc/testsuite/gfortran.dg/team_change_3.f90 b/gcc/testsuite/gfortran.dg/team_change_3.f90
new file mode 100644
index 00000000000..bc30c40bb6d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_change_3.f90
@@ -0,0 +1,29 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests change team stat= and errmsg= specifiers
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+ integer :: new_team, istat = 42
+ character(len=30) :: err = 'unchanged'
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ change team (team, stat=istat)
+ if (istat /= 0) stop 1
+ end team
+
+ change team (team, stat=istat, errmsg=err)
+ if (trim(err) /= 'unchanged') stop 2
+ end team
+
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_end_2.f90 b/gcc/testsuite/gfortran.dg/team_end_2.f90
new file mode 100644
index 00000000000..64f072aed3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_end_2.f90
@@ -0,0 +1,33 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests change team syntax
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+ integer :: new_team, istat
+ character(len=30) :: err
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ change team (team)
+ continue
+ end team (stat=err) ! { dg-error "must be a scalar INTEGER" }
+
+ change team (team)
+ continue
+ end team (stat=istat, stat=istat) ! { dg-error "Duplicate STAT" }
+
+ change team (team)
+ continue
+ end team (stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" }
+
+ change team (team)
+ continue
+ end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+end
+
diff --git a/gcc/testsuite/gfortran.dg/team_end_3.f90 b/gcc/testsuite/gfortran.dg/team_end_3.f90
new file mode 100644
index 00000000000..5e004ada64f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_end_3.f90
@@ -0,0 +1,39 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests end team stat= and errmsg= specifiers
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ type(team_type) :: team
+ integer :: new_team, istat = 42
+ character(len=30) :: err = 'unchanged'
+ integer, allocatable :: sample(:)[:]
+ integer, allocatable :: scal_caf[:]
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+
+ change team (team)
+ allocate(sample(5)[*], scal_caf[*])
+ if (.NOT. allocated(sample)) stop 1
+ if (.NOT. allocated(scal_caf)) stop 2
+ end team (stat=istat)
+ if (istat /= 0) stop 3
+ if (allocated(sample)) stop 4
+ if (allocated(scal_caf)) stop 5
+
+ deallocate(sample, stat=istat)
+ if (istat == 0) stop 6
+
+ change team (team)
+ continue
+ end team (stat=istat, errmsg=err)
+ if (trim(err) /= 'unchanged') stop 7
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_form_2.f90 b/gcc/testsuite/gfortran.dg/team_form_2.f90
new file mode 100644
index 00000000000..5c6d81ffb87
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_form_2.f90
@@ -0,0 +1,27 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Tests form team syntax errors
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ integer :: istat, new_team
+ character(len=30) :: err
+ type(team_type) :: team
+
+ new_team = mod(this_image(),2)+1
+
+ form team ! { dg-error "Syntax error in FORM TEAM statement" }
+ form team (new_team) ! { dg-error "Syntax error in FORM TEAM statement" }
+ form team (new_team,err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" }
+ form team (new_team,team,istat) ! { dg-error "Syntax error in FORM TEAM statement" }
+ form team (new_team,team,stat=istat,stat=istat) ! { dg-error "Duplicate STAT" }
+ form team (new_team,team,stat=istat,errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" }
+ form team (new_team,team,stat=istat,errmsg=err,errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+ form team (new_team,team,new_index=1,new_index=1) ! { dg-error "Duplicate NEW_INDEX" }
+ form team (new_team,team,new_index=err) ! { dg-error "must be a scalar INTEGER" }
+ form team (new_team,team,new_index=1,new_index=1,stat=istat,errmsg=err) ! { dg-error "Duplicate NEW_INDEX" }
+ form team (new_team,team,new_index=1,stat=istat,errmsg=err,new_index=9) ! { dg-error "Duplicate NEW_INDEX" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/team_form_3.f90 b/gcc/testsuite/gfortran.dg/team_form_3.f90
new file mode 100644
index 00000000000..d9aae3376ea
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_form_3.f90
@@ -0,0 +1,34 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Tests form team with stat= and errmsg=
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ integer :: istat = 42, new_team
+ character(len=30) :: err = "unchanged"
+ type(team_type) :: team
+
+ new_team = mod(this_image(),2)+1
+
+ form team (new_team,team)
+ form team (new_team,team,stat=istat)
+ if (istat /= 0) stop 1
+ form team (new_team,team,stat=istat, errmsg=err)
+ if (trim(err) /= 'unchanged') stop 2
+ form team (new_team,team,new_index=1)
+ istat = 42
+ form team (new_team,team,new_index=1,stat=istat)
+ if (istat /= 0) stop 3
+ form team (new_team,team,new_index=1,stat=istat,errmsg=err)
+ if (trim(err) /= 'unchanged') stop 4
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, &err, 30\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, &err, 30\\)" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/team_sync_2.f90 b/gcc/testsuite/gfortran.dg/team_sync_2.f90
new file mode 100644
index 00000000000..947f65db895
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_sync_2.f90
@@ -0,0 +1,27 @@
+!{ dg-do run }
+!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+!{ dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Test sync team statement
+!
+ use iso_fortran_env, only : team_type
+ implicit none
+ integer :: istat = 42
+ type(team_type) :: team
+ character(len=30) :: err = "unchanged"
+
+ form team (mod(this_image(),2)+1, team)
+
+ change team (team)
+ sync team (team)
+ sync team (team, stat=istat)
+ if (istat /= 0) stop 1
+ sync team (team, stat=istat, errmsg=err)
+ if (trim(err) /= 'unchanged') stop 2
+ end team
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, 0B, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, 0B, 0\\)" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, &err, 30\\)" "original" } }
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 0b371d02a18..a674a1929e5 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -31,17 +31,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "libgfortran.h"
-#if 0
-#ifndef __GNUC__
-#define __attribute__(x)
-#define likely(x) (x)
-#define unlikely(x) (x)
-#else
-#define likely(x) __builtin_expect(!!(x), 1)
-#define unlikely(x) __builtin_expect(!!(x), 0)
-#endif
-#endif
-
/* Definitions of the Fortran 2008 standard; need to kept in sync with
ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */
typedef enum
@@ -78,8 +67,8 @@ typedef enum caf_deregister_t {
}
caf_deregister_t;
-typedef void* caf_token_t;
-typedef void * caf_team_t;
+typedef void *caf_token_t;
+typedef void *caf_team_t;
typedef gfc_array_void gfc_descriptor_t;
/* Linked list of static coarrays registered. */
@@ -185,4 +174,9 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *,
void _gfortran_caf_random_init (bool, bool);
+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);
+
#endif /* LIBCAF_H */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 1d7af6b8972..a705699bfa9 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -50,6 +50,21 @@ typedef struct caf_single_token *caf_single_token_t;
#define TOKEN(X) ((caf_single_token_t) (X))
#define MEMTOK(X) ((caf_single_token_t) (X))->memptr
+struct caf_single_team
+{
+ struct caf_single_team *parent;
+ int team_no;
+ struct coarray_allocated
+ {
+ struct coarray_allocated *next;
+ caf_single_token_t token;
+ } *allocated;
+};
+typedef struct caf_single_team *caf_single_team_t;
+/* This points to the most current team. */
+static caf_single_team_t caf_team_stack = NULL, caf_initial_team;
+static caf_single_team_t caf_teams_formed = NULL;
+
/* Single-image implementation of the CAF library.
Note: For performance reasons -fcoarry=single should be used
rather than this library. */
@@ -125,13 +140,39 @@ caf_internal_error (const char *msg, int *stat, char *errmsg,
va_end (args);
}
+static void
+init_caf_team_stack (void)
+{
+ caf_initial_team = caf_team_stack
+ = (caf_single_team_t) calloc (1, sizeof (struct caf_single_team));
+ caf_initial_team->team_no = -1;
+}
void
_gfortran_caf_init (int *argc __attribute__ ((unused)),
char ***argv __attribute__ ((unused)))
{
+ if (likely (!caf_team_stack))
+ init_caf_team_stack ();
}
+static void
+free_team_list (caf_single_team_t l)
+{
+ while (l != NULL)
+ {
+ caf_single_team_t p = l->parent;
+ struct coarray_allocated *ca = l->allocated;
+ while (ca)
+ {
+ struct coarray_allocated *nca = ca->next;
+ free (ca);
+ ca = nca;
+ }
+ free (l);
+ l = p;
+ }
+}
void
_gfortran_caf_finalize (void)
@@ -146,6 +187,11 @@ _gfortran_caf_finalize (void)
free (caf_static_list);
caf_static_list = tmp;
}
+
+ free_team_list (caf_team_stack);
+ caf_initial_team = caf_team_stack = NULL;
+ free_team_list (caf_teams_formed);
+ caf_teams_formed = NULL;
}
@@ -206,6 +252,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
+ if (unlikely (!caf_team_stack))
+ init_caf_team_stack ();
if (stat)
*stat = 0;
@@ -219,6 +267,20 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
tmp->token = *token;
caf_static_list = tmp;
}
+ else
+ {
+ struct coarray_allocated *ca = caf_team_stack->allocated;
+ for (; ca && ca->token != single_token; ca = ca->next)
+ ;
+ if (!ca)
+ {
+ ca = (struct coarray_allocated *) malloc (
+ sizeof (struct coarray_allocated));
+ *ca = (struct coarray_allocated) {caf_team_stack->allocated,
+ single_token};
+ caf_team_stack->allocated = ca;
+ }
+ }
GFC_DESCRIPTOR_DATA (data) = local;
}
@@ -231,10 +293,30 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
caf_single_token_t single_token = TOKEN (*token);
if (single_token->owning_memory && single_token->memptr)
- free (single_token->memptr);
+ {
+ free (single_token->memptr);
+ if (single_token->desc)
+ GFC_DESCRIPTOR_DATA (single_token->desc) = NULL;
+ }
if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
{
+ struct coarray_allocated *ca = caf_team_stack->allocated;
+ if (ca && caf_team_stack->allocated->token == single_token)
+ caf_team_stack->allocated = ca->next;
+ else
+ {
+ struct coarray_allocated *pca = NULL;
+ for (; ca && ca->token != single_token; pca = ca, ca = ca->next)
+ ;
+ if (!ca)
+ caf_runtime_error (
+ "Coarray token to be freeed is not in current team %d", type);
+ /* Unhook found coarray_allocated node from list... */
+ pca->next = ca->next;
+ }
+ /* ... and free. */
+ free (ca);
free (TOKEN (*token));
*token = NULL;
}
@@ -599,11 +681,10 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,
int32_t result;
struct caf_single_token cb_token = {add_data, NULL, false};
-
- accessor_hash_table[present_index].u.is_present (add_data, &image_index,
- &result,
- single_token->memptr,
- &cb_token, 0);
+ accessor_hash_table[present_index].u.is_present (
+ add_data, &image_index, &result,
+ single_token->desc ? single_token->desc : (void *) &single_token->memptr,
+ &cb_token, 0);
return result;
}
@@ -923,3 +1004,83 @@ void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
routine. */
_gfortran_random_init (repeatable, image_distinct, 1);
}
+
+void
+_gfortran_caf_form_team (int team_no, caf_team_t *team,
+ int *new_index __attribute__ ((unused)), int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ const char alloc_fail_msg[] = "Failed to allocate team";
+ caf_single_team_t t;
+ if (stat)
+ *stat = 0;
+
+ *team = malloc (sizeof (struct caf_single_team));
+ if (unlikely (*team == NULL))
+ {
+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+ return;
+ }
+ t = *((caf_single_team_t *) team);
+ t->parent = caf_teams_formed;
+ t->team_no = team_no;
+ t->allocated = NULL;
+ caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_change_team (caf_team_t team, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ caf_single_team_t t = (caf_single_team_t) team;
+
+ if (stat)
+ *stat = 0;
+
+ if (t == caf_teams_formed)
+ caf_teams_formed = t->parent;
+ else
+ for (caf_single_team_t p = caf_teams_formed; p; p = p->parent)
+ if (p->parent == t)
+ {
+ p->parent = t->parent;
+ break;
+ }
+
+ t->parent = caf_team_stack;
+ caf_team_stack = t;
+}
+
+void
+_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)
+{
+ caf_single_team_t t = caf_team_stack;
+
+ if (stat)
+ *stat = 0;
+
+ caf_team_stack = caf_team_stack->parent;
+ for (struct coarray_allocated *ca = t->allocated; ca;)
+ {
+ struct coarray_allocated *nca = ca->next;
+ _gfortran_caf_deregister ((caf_token_t *) &ca->token,
+ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat,
+ errmsg, errmsg_len);
+ free (ca);
+ ca = nca;
+ }
+ t->allocated = NULL;
+ t->parent = caf_teams_formed;
+ caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_sync_team (caf_team_t team __attribute__ ((unused)), int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
--
2.49.0
