https://gcc.gnu.org/g:8f4ee36bd5248cd244f65282167e3a13a3c98bc2
commit r16-75-g8f4ee36bd5248cd244f65282167e3a13a3c98bc2
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Mon Apr 7 09:36:24 2025 +0200
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.
Diff:
---
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 | 89 ++++++---
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, 1116 insertions(+), 209 deletions(-)
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index 70583254d0d8..2f067f855e54 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 feb454ea5b36..69acd2da9815 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 4ace093738ca..dd920f3ab08a 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 ef9c80147cc4..02a0a2326a66 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 963216173085..ff385671d214 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 8c160e58b00a..ad89064cb595 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 b8926f4df93b..970f09fddd3a 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 4d77e094ab9f..0d81b69025e0 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 a95bb62afb8c..538eb65b4bfe 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 722e94cef541..7bf0fa497e92 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 e9053b49392b..e51f83b6618b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11519,6 +11519,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)
{
@@ -11665,8 +11721,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
if (code->here == label)
{
- gfc_warning (0,
- "Branch at %L may result in an infinite loop", &code->loc);
+ gfc_warning (0, "Branch at %L may result in an infinite loop",
+ &code->loc);
return;
}
@@ -11689,6 +11745,10 @@ 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;
@@ -13325,23 +13385,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. */
@@ -13530,15 +13573,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 5e5311e4f0c2..ae996a05f07e 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 62dd38d6f9d0..276f325cc483 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 16ade8d4d552..cab3ebc00086 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 e79209e94aa0..f128b4c843ba 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 000000000000..00cc489bf1fd
--- /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 000000000000..bc30c40bb6d7
--- /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 000000000000..64f072aed3de
--- /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 000000000000..5e004ada64f7
--- /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 000000000000..5c6d81ffb873
--- /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 000000000000..d9aae3376ead
--- /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 000000000000..947f65db8957
--- /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 0b371d02a18b..a674a1929e53 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 1d7af6b89722..a705699bfa93 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;
+}
