https://gcc.gnu.org/g:1be1970f97d05a07851cd826132fcf466827ebe5
commit r16-74-g1be1970f97d05a07851cd826132fcf466827ebe5
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri Mar 14 14:20:18 2025 +0100
Fortran: Unify handling of STAT= and ERRMSG= optional arguments [PR87939]
In preparing F2018 Teams handling improvements, unify handling of STAT=
and ERRMSG= optional arguments. Handling of stat and errmsg in most
teams statements is corrected in the next patch.
Implement stat and errmsg for move_alloc () to comply with F2018.
PR fortran/87939
gcc/fortran/ChangeLog:
* check.cc (gfc_check_move_alloc): Add stat and errmsg to
move_alloc.
* dump-parse-tree.cc (show_sync_stat): New helper function.
(show_code_node): Use show_sync_stat to print stat and errmsg.
* gfortran.h (struct sync_stat): New struct to unify stat and
errmsg handling.
* intrinsic.cc (add_subroutines): Correct signature of
move_alloc.
* intrinsic.h (gfc_check_move_alloc): Correct signature of
check_move_alloc.
* match.cc (match_named_arg): Match an optional argument to a
statement.
(match_stat_errmsg): Match a stat= or errmsg= named argument.
(gfc_match_critical): Use match_stat_errmsg to match the named
arguments.
(gfc_match_sync_team): Same.
* resolve.cc (resolve_team_argument): Resolve an expr to have
type TEAM_TYPE from iso_fortran_env.
(resolve_scalar_variable_as_arg): Resolve an argument as a
scalar type.
(resolve_sync_stat): Resolve stat and errmsg expressions.
(resolve_sync_team): Resolve a sync team statement using
sync_stat helper.
(resolve_end_team): Same.
(resolve_critical): Same.
* trans-decl.cc (gfc_build_builtin_function_decls): Correct
sync_team signature.
* trans-intrinsic.cc (conv_intrinsic_move_alloc): Store stat
an errmsg optional arguments in helper struct and use helper
to translate.
* trans-stmt.cc (trans_exit): Implement DRY pattern for
generating an _exit().
(gfc_trans_sync_stat): Translate stat and errmsg contents.
(gfc_trans_end_team): Use helper to translate stat and errmsg.
(gfc_trans_sync_team): Same.
(gfc_trans_critical): Same.
* trans-stmt.h (gfc_trans_sync_stat): New function.
* trans.cc (gfc_deallocate_with_status): Parameterize check at
runtime to allow unallocated (co-)array when freeing a
structure.
(gfc_deallocate_scalar_with_status): Same and also add errmsg.
* trans.h (gfc_deallocate_with_status): Signature changes.
(gfc_deallocate_scalar_with_status): Same.
libgfortran/ChangeLog:
* caf/single.c (_gfortran_caf_lock): Correct stat value, if
lock is already locked by current image.
(_gfortran_caf_unlock): Correct stat value, if lock is not
locked.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray_critical_2.f90: New test.
* gfortran.dg/coarray_critical_3.f90: New test.
* gfortran.dg/team_sync_1.f90: New test.
* gfortran.dg/move_alloc_11.f90: New test.
Diff:
---
gcc/fortran/check.cc | 12 +-
gcc/fortran/dump-parse-tree.cc | 23 ++-
gcc/fortran/gfortran.h | 9 ++
gcc/fortran/intrinsic.cc | 10 +-
gcc/fortran/intrinsic.h | 3 +-
gcc/fortran/match.cc | 121 +++++++++++++--
gcc/fortran/resolve.cc | 52 ++++++-
gcc/fortran/trans-decl.cc | 8 +-
gcc/fortran/trans-intrinsic.cc | 61 ++++++--
gcc/fortran/trans-stmt.cc | 186 +++++++++++++++--------
gcc/fortran/trans-stmt.h | 1 +
gcc/fortran/trans.cc | 46 +++---
gcc/fortran/trans.h | 11 +-
gcc/testsuite/gfortran.dg/coarray_critical_2.f90 | 30 ++++
gcc/testsuite/gfortran.dg/coarray_critical_3.f90 | 32 ++++
gcc/testsuite/gfortran.dg/move_alloc_11.f90 | 23 +++
gcc/testsuite/gfortran.dg/team_sync_1.f90 | 24 +++
libgfortran/caf/single.c | 8 +-
18 files changed, 532 insertions(+), 128 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 9c66c25e0596..00342787a518 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4683,8 +4683,18 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr
*mask)
bool
-gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
+gfc_check_move_alloc (gfc_expr *from, gfc_expr *to, gfc_expr *stat,
+ gfc_expr *errmsg)
{
+ struct sync_stat sync_stat = {stat, errmsg};
+
+ if ((stat || errmsg)
+ && !gfc_notify_std (GFC_STD_F2008, "STAT= or ERRMSG= at %L not
supported",
+ &to->where))
+ return false;
+
+ gfc_resolve_sync_stat (&sync_stat);
+
if (!variable_check (from, 0, false))
return false;
if (!allocatable_check (from, 0))
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 9501bccb803b..4ace093738ca 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2607,6 +2607,20 @@ show_omp_node (int level, gfc_code *c)
fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
}
+static void
+show_sync_stat (struct sync_stat *sync_stat)
+{
+ if (sync_stat->stat)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (sync_stat->stat);
+ }
+ if (sync_stat->errmsg)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (sync_stat->errmsg);
+ }
+}
/* Show a single code node and everything underneath it if necessary. */
@@ -2761,6 +2775,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_END_TEAM:
fputs ("END TEAM", dumpfile);
+ show_sync_stat (&c->ext.sync_stat);
break;
case EXEC_FORM_TEAM:
@@ -2768,7 +2783,9 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_SYNC_TEAM:
- fputs ("SYNC TEAM", dumpfile);
+ fputs ("SYNC TEAM ", dumpfile);
+ show_expr (c->expr1);
+ show_sync_stat (&c->ext.sync_stat);
break;
case EXEC_SYNC_ALL:
@@ -3048,7 +3065,9 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_CRITICAL:
- fputs ("CRITICAL\n", dumpfile);
+ fputs ("CRITICAL", dumpfile);
+ show_sync_stat (&c->ext.sync_stat);
+ fputc ('\n', dumpfile);
show_code (level + 1, c->block->next);
code_indent (level, 0);
fputs ("END CRITICAL", dumpfile);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5ef70378b1b5..46310a088f26 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3162,6 +3162,11 @@ enum locality_type
LOCALITY_NUM
};
+struct sync_stat
+{
+ gfc_expr *stat, *errmsg;
+};
+
typedef struct gfc_code
{
gfc_exec_op op;
@@ -3197,6 +3202,7 @@ typedef struct gfc_code
gfc_omp_variant *omp_variants;
bool omp_bool;
int stop_code;
+ struct sync_stat sync_stat;
struct
{
@@ -3207,6 +3213,7 @@ typedef struct gfc_code
unsigned arr_spec_from_expr3:1;
/* expr3 is not explicit */
unsigned expr3_not_explicit:1;
+ struct sync_stat sync_stat;
}
alloc;
@@ -3215,6 +3222,7 @@ typedef struct gfc_code
gfc_namespace *ns;
gfc_association_list *assoc;
gfc_case *case_list;
+ struct sync_stat sync_stat;
}
block;
@@ -3985,6 +3993,7 @@ bool gfc_resolve_index (gfc_expr *, int);
bool gfc_resolve_dim_arg (gfc_expr *);
bool gfc_resolve_substring (gfc_ref *, bool *);
void gfc_resolve_substring_charlen (gfc_expr *);
+void gfc_resolve_sync_stat (struct sync_stat *);
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index d2ce74f16eb5..91f16c7f35f9 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3835,11 +3835,11 @@ add_subroutines (void)
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
- add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0,
- GFC_STD_F2003,
- gfc_check_move_alloc, NULL, NULL,
- f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
- t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
+ add_sym_4s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0,
+ GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL, f, BT_UNKNOWN, 0,
+ REQUIRED, INTENT_INOUT, t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER,
+ dc, OPTIONAL, INTENT_INOUT);
add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fec1c24a0995..70e14c4098b1 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -208,7 +208,8 @@ bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr
*);
bool gfc_check_gerror (gfc_expr *);
bool gfc_check_getarg (gfc_expr *, gfc_expr *);
bool gfc_check_getlog (gfc_expr *);
-bool gfc_check_move_alloc (gfc_expr *, gfc_expr *);
+bool gfc_check_move_alloc (gfc_expr *, gfc_expr *, gfc_expr *stat,
+ gfc_expr *errmsg);
bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
bool gfc_check_random_init (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index ec9e5873204a..4d77e094ab9f 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -1814,12 +1814,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag)
free (iter);
}
+static match
+match_named_arg (const char *pat, const char *name, gfc_expr **e,
+ gfc_statement st_code)
+{
+ match m;
+ gfc_expr *tmp;
+
+ m = gfc_match (pat, &tmp);
+ if (m == MATCH_ERROR)
+ {
+ gfc_syntax_error (st_code);
+ return m;
+ }
+ if (m == MATCH_YES)
+ {
+ if (*e)
+ {
+ gfc_error ("Duplicate %s attribute in %C", name);
+ gfc_free_expr (tmp);
+ return MATCH_ERROR;
+ }
+ *e = tmp;
+
+ return MATCH_YES;
+ }
+ return MATCH_NO;
+}
+
+static match
+match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code)
+{
+ match m;
+
+ m = match_named_arg (" stat = %v", "STAT", &sync_stat->stat, st_code);
+ if (m != MATCH_NO)
+ return m;
+
+ m = match_named_arg (" errmsg = %v", "ERRMSG", &sync_stat->errmsg, st_code);
+ return m;
+}
/* Match a CRITICAL statement. */
match
gfc_match_critical (void)
{
gfc_st_label *label = NULL;
+ match m;
if (gfc_match_label () == MATCH_ERROR)
return MATCH_ERROR;
@@ -1830,12 +1871,29 @@ gfc_match_critical (void)
if (gfc_match_st_label (&label) == MATCH_ERROR)
return MATCH_ERROR;
- if (gfc_match_eos () != MATCH_YES)
+ if (gfc_match_eos () == MATCH_YES)
+ goto done;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ for (;;)
{
- gfc_syntax_error (ST_CRITICAL);
- return MATCH_ERROR;
+ m = match_stat_errmsg (&new_st.ext.sync_stat, ST_CRITICAL);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+
+ break;
}
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+
if (gfc_pure (NULL))
{
gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
@@ -1856,9 +1914,9 @@ gfc_match_critical (void)
if (flag_coarray == GFC_FCOARRAY_NONE)
{
- gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
- "enable");
- return MATCH_ERROR;
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
+ "enable");
+ return MATCH_ERROR;
}
if (gfc_find_state (COMP_CRITICAL))
@@ -1869,13 +1927,21 @@ gfc_match_critical (void)
new_st.op = EXEC_CRITICAL;
- if (label != NULL
- && !gfc_reference_st_label (label, ST_LABEL_TARGET))
- return MATCH_ERROR;
+ if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET))
+ goto cleanup;
return MATCH_YES;
-}
+syntax:
+ gfc_syntax_error (ST_CRITICAL);
+
+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};
+
+ return MATCH_ERROR;
+}
/* Match a BLOCK statement. */
@@ -3941,7 +4007,7 @@ match
gfc_match_sync_team (void)
{
match m;
- gfc_expr *team;
+ gfc_expr *team = NULL;
if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C"))
return MATCH_ERROR;
@@ -3954,10 +4020,34 @@ gfc_match_sync_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_SYNC_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;
@@ -3965,6 +4055,13 @@ gfc_match_sync_team (void)
syntax:
gfc_syntax_error (ST_SYNC_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};
+
+ gfc_free_expr (team);
+
return MATCH_ERROR;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f03708efef78..e9053b49392b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11484,6 +11484,53 @@ resolve_lock_unlock_event (gfc_code *code)
}
}
+static void
+resolve_team_argument (gfc_expr *team)
+{
+ gfc_resolve_expr (team);
+ 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 at %L must be a scalar expression "
+ "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
+ &team->where);
+ }
+}
+
+static void
+resolve_scalar_variable_as_arg (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
+ || e->expr_type != EXPR_VARIABLE))
+ gfc_error ("%s argument at %L must be a scalar %s variable of at least "
+ "kind %d", name, &e->where, gfc_basic_typename (exp_type),
+ exp_kind);
+}
+
+void
+gfc_resolve_sync_stat (struct sync_stat *sync_stat)
+{
+ resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
+ resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
+ gfc_default_character_kind,
+ sync_stat->errmsg);
+}
+static void
+resolve_sync_team (gfc_code *code)
+{
+ resolve_team_argument (code->expr1);
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
+
+static void
+resolve_end_team (gfc_code *code)
+{
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
static void
resolve_critical (gfc_code *code)
@@ -11493,6 +11540,8 @@ resolve_critical (gfc_code *code)
char name[GFC_MAX_SYMBOL_LEN];
static int serial = 0;
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+
if (flag_coarray != GFC_FCOARRAY_LIB)
return;
@@ -13493,10 +13542,11 @@ start:
break;
case EXEC_END_TEAM:
+ resolve_end_team (code);
break;
case EXEC_SYNC_TEAM:
- check_team (code->expr1, "SYNC TEAM");
+ resolve_sync_team (code);
break;
case EXEC_ENTRY:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index ddc4960b6fff..5e5311e4f0c2 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4222,11 +4222,9 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("caf_get_team")),
void_type_node, 1, integer_type_node);
- gfor_fndecl_caf_sync_team
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_sync_team")), ". r . ",
- void_type_node, 2, ppvoid_type_node,
- integer_type_node);
+ gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
+ 4, pvoid_type_node, pint_type, pchar_type_node, size_type_node);
gfor_fndecl_caf_team_number
= gfc_build_library_function_decl_with_spec (
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 6ffc3e0261e5..16ade8d4d552 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -12970,6 +12970,9 @@ gfc_conv_intrinsic_mvbits (gfc_se *se,
gfc_actual_arglist *actual_args,
void_type_node, to, se->expr);
}
+/* Comes from trans-stmt.cc, but we don't want the whole header included. */
+extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
+ tree *stat, tree *errmsg, tree *errmsg_len);
static tree
conv_intrinsic_move_alloc (gfc_code *code)
@@ -12977,17 +12980,37 @@ conv_intrinsic_move_alloc (gfc_code *code)
stmtblock_t block;
gfc_expr *from_expr, *to_expr;
gfc_se from_se, to_se;
- tree tmp, to_tree, from_tree;
+ tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label =
NULL_TREE;
bool coarray, from_is_class, from_is_scalar;
+ gfc_actual_arglist *arg = code->ext.actual;
+ sync_stat tmp_sync_stat = {nullptr, nullptr};
gfc_start_block (&block);
- from_expr = code->ext.actual->expr;
- to_expr = code->ext.actual->next->expr;
+ from_expr = arg->expr;
+ arg = arg->next;
+ to_expr = arg->expr;
+ arg = arg->next;
+
+ while (arg)
+ {
+ if (arg->expr)
+ {
+ if (!strcmp ("stat", arg->name))
+ tmp_sync_stat.stat = arg->expr;
+ else if (!strcmp ("errmsg", arg->name))
+ tmp_sync_stat.errmsg = arg->expr;
+ }
+ arg = arg->next;
+ }
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
+ gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
+ if (stat != null_pointer_node)
+ fin_label = gfc_build_label_decl (NULL_TREE);
+
gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
coarray = from_expr->corank != 0;
@@ -13030,9 +13053,10 @@ conv_intrinsic_move_alloc (gfc_code *code)
/* Deallocate "to". */
if (to_expr->rank == 0)
{
- tmp
- = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE,
- true, to_expr, to_expr->ts);
+ tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
+ true, to_expr, to_expr->ts,
+ NULL_TREE, false, true,
+ errmsg, errmsg_len);
gfc_add_expr_to_block (&block, tmp);
}
@@ -13105,9 +13129,12 @@ conv_intrinsic_move_alloc (gfc_code *code)
{
tree cond;
- tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, true, to_expr,
- GFC_CAF_COARRAY_DEALLOCATE_ONLY);
+ tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
+ fin_label, true, to_expr,
+ GFC_CAF_COARRAY_DEALLOCATE_ONLY,
+ NULL_TREE, NULL_TREE,
+ gfc_conv_descriptor_token (to_se.expr),
+ true);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_conv_descriptor_data_get (to_se.expr);
@@ -13133,9 +13160,10 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_add_expr_to_block (&block, tmp);
}
- tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, true, to_expr,
- GFC_CAF_COARRAY_NOCOARRAY);
+ tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
+ fin_label, true, to_expr,
+ GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
+ NULL_TREE, NULL_TREE, true);
gfc_add_expr_to_block (&block, tmp);
}
@@ -13147,6 +13175,13 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_add_modify_loc (input_location, &block, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ /* Copy the array descriptor data has overwritten the to-token and
cleared
+ from.data. Now also clear the from.token. */
+ gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
+ null_pointer_node);
+ }
if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
{
@@ -13157,6 +13192,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_add_modify_loc (input_location, &block, from_se.string_length,
build_int_cst (TREE_TYPE (from_se.string_length), 0));
}
+ if (fin_label)
+ gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
return gfc_finish_block (&block);
}
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 37f8acaea3f6..e79209e94aa0 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -721,6 +721,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
return gfc_finish_block (&se.pre);
}
+tree
+trans_exit ()
+{
+ 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);
+}
+
/* Translate the FAIL IMAGE statement. */
tree
@@ -730,11 +739,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
return build_call_expr_loc (input_location,
gfor_fndecl_caf_fail_image, 0);
else
+ return trans_exit ();
+}
+
+void
+gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat,
+ tree *errmsg, tree *errmsg_len)
+{
+ gfc_se argse;
+
+ if (sync_stat->stat)
{
- 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);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr (&argse, sync_stat->stat);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+
+ if (TREE_TYPE (argse.expr) != integer_type_node)
+ {
+ tree tstat = gfc_create_var (integer_type_node, "stat");
+ TREE_THIS_VOLATILE (tstat) = 1;
+ gfc_add_modify (&se->pre, tstat,
+ fold_convert (integer_type_node, argse.expr));
+ gfc_add_modify (&se->post, argse.expr,
+ fold_convert (TREE_TYPE (argse.expr), tstat));
+ *stat = build_fold_addr_expr (tstat);
+ }
+ else
+ *stat = build_fold_addr_expr (argse.expr);
+ }
+ else
+ *stat = null_pointer_node;
+
+ if (sync_stat->errmsg)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_reference (&argse, sync_stat->errmsg);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ *errmsg = argse.expr;
+ *errmsg_len = fold_convert (size_type_node, argse.string_length);
+ }
+ else
+ {
+ *errmsg = null_pointer_node;
+ *errmsg_len = build_zero_cst (size_type_node);
}
}
@@ -812,21 +859,27 @@ gfc_trans_change_team (gfc_code *code)
/* Translate the END TEAM statement. */
tree
-gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED)
+gfc_trans_end_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- return build_call_expr_loc (input_location,
- gfor_fndecl_caf_end_team, 1,
- build_int_cst (pchar_type_node, 0));
+ gfc_se se;
+ tree stat, errmsg, errmsg_len, tmp;
+
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+
+ gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+ &errmsg_len);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3,
+ stat, errmsg, errmsg_len);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ 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 SYNC TEAM statement. */
@@ -836,28 +889,25 @@ gfc_trans_sync_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- gfc_se argse;
- tree team_type, tmp;
+ 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);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_sync_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.sync_stat, &se, &stat, &errmsg,
+ &errmsg_len);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_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);
+ 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 ();
}
tree
@@ -1609,35 +1659,41 @@ gfc_trans_arithmetic_if (gfc_code * code)
/* Translate a CRITICAL block. */
+
tree
gfc_trans_critical (gfc_code *code)
-{
- stmtblock_t block;
- tree tmp, token = NULL_TREE;
+ {
+ stmtblock_t block;
+ tree tmp, token = NULL_TREE;
+ tree stat = NULL_TREE, errmsg, errmsg_len;
- gfc_start_block (&block);
+ gfc_start_block (&block);
- if (flag_coarray == GFC_FCOARRAY_LIB)
- {
- tree zero_size = build_zero_cst (size_type_node);
- token = gfc_get_symbol_decl (code->resolved_sym);
- token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
- token, zero_size, integer_one_node,
- null_pointer_node, null_pointer_node,
- null_pointer_node, zero_size);
- gfc_add_expr_to_block (&block, tmp);
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se se;
- /* It guarantees memory consistency within the same segment */
- tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
- tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
- gfc_build_string_const (1, ""),
- NULL_TREE, NULL_TREE,
- tree_cons (NULL_TREE, tmp, NULL_TREE),
- NULL_TREE);
- ASM_VOLATILE_P (tmp) = 1;
+ gfc_init_se (&se, NULL);
+ gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
+ &errmsg_len);
+ gfc_add_block_to_block (&block, &se.pre);
- gfc_add_expr_to_block (&block, tmp);
+ token = gfc_get_symbol_decl (code->resolved_sym);
+ token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
+ token, integer_zero_node, integer_one_node,
+ null_pointer_node, stat, errmsg, errmsg_len);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se.post);
+
+ /* It guarantees memory consistency within the same segment. */
+ tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"),
+ tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
+ gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
+ tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
+ ASM_VOLATILE_P (tmp) = 1;
+
+ gfc_add_expr_to_block (&block, tmp);
}
tmp = gfc_trans_code (code->block->next);
@@ -1645,11 +1701,19 @@ gfc_trans_critical (gfc_code *code)
if (flag_coarray == GFC_FCOARRAY_LIB)
{
- tree zero_size = build_zero_cst (size_type_node);
- tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
- token, zero_size, integer_one_node,
- null_pointer_node, null_pointer_node,
- zero_size);
+ /* END CRITICAL does not accept STAT or ERRMSG arguments.
+ * If STAT= is specified for CRITICAL, pass a stat argument to
+ * _gfortran_caf_lock_unlock to prevent termination in the event of an
+ * error, but ignore any value assigned to it.
+ */
+ tmp = build_call_expr_loc (
+ input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node,
+ integer_one_node,
+ stat != NULL_TREE
+ ? gfc_build_addr_expr (NULL,
+ gfc_create_var (integer_type_node, "stat"))
+ : null_pointer_node,
+ null_pointer_node, integer_zero_node);
gfc_add_expr_to_block (&block, tmp);
/* It guarantees memory consistency within the same segment */
@@ -1981,7 +2045,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
}
- if (sym->attr.codimension && !sym->attr.dimension)
+ if (sym->attr.codimension)
se.want_coarray = 1;
gfc_conv_expr_descriptor (&se, e);
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 67b1970776b9..8fbcdcba1f98 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -58,6 +58,7 @@ tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_fail_image (gfc_code *);
+void gfc_trans_sync_stat (struct sync_stat *, gfc_se *, tree *, tree *, tree
*);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_form_team (gfc_code *);
tree gfc_trans_change_team (gfc_code *);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index b03dcc1fb1a4..fdeb1e89a765 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1795,11 +1795,11 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
analyzed and set by this routine, and -2 to indicate that a non-coarray is
to
be deallocated. */
tree
-gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
- tree errlen, tree label_finish,
- bool can_fail, gfc_expr* expr,
+gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree
errlen,
+ tree label_finish, bool can_fail, gfc_expr *expr,
int coarray_dealloc_mode, tree class_container,
- tree add_when_allocated, tree caf_token)
+ tree add_when_allocated, tree caf_token,
+ bool unalloc_ok)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
@@ -1891,7 +1891,7 @@ gfc_deallocate_with_status (tree pointer, tree status,
tree errmsg,
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
- build_int_cst (status_type, 1));
+ build_int_cst (status_type, unalloc_ok ? 0 : 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
@@ -1975,10 +1975,10 @@ gfc_deallocate_with_status (tree pointer, tree status,
tree errmsg,
token = gfc_build_addr_expr (NULL_TREE, token);
gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 5,
- token, build_int_cst (integer_type_node,
- caf_dereg_type),
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5,
+ token,
+ build_int_cst (integer_type_node,
+ caf_dereg_type),
pstat, errmsg, errlen);
gfc_add_expr_to_block (&non_null, tmp);
@@ -1990,7 +1990,7 @@ gfc_deallocate_with_status (tree pointer, tree status,
tree errmsg,
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&non_null, tmp);
- if (status != NULL_TREE)
+ if (status != NULL_TREE && !integer_zerop (status))
{
tree stat = build_fold_indirect_ref_loc (input_location, status);
tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
@@ -2024,9 +2024,10 @@ gfc_deallocate_with_status (tree pointer, tree status,
tree errmsg,
tree
gfc_deallocate_scalar_with_status (tree pointer, tree status, tree
label_finish,
- bool can_fail, gfc_expr* expr,
+ bool can_fail, gfc_expr *expr,
gfc_typespec ts, tree class_container,
- bool coarray)
+ bool coarray, bool unalloc_ok, tree errmsg,
+ tree errmsg_len)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
@@ -2069,7 +2070,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree
status, tree label_finish,
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
- build_int_cst (status_type, 1));
+ build_int_cst (status_type, unalloc_ok ? 0 : 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
@@ -2134,7 +2135,8 @@ gfc_deallocate_scalar_with_status (tree pointer, tree
status, tree label_finish,
else
{
tree token;
- tree pstat = null_pointer_node;
+ tree pstat = null_pointer_node, perrmsg = null_pointer_node,
+ perrlen = size_zero_node;
gfc_se se;
gfc_init_se (&se, NULL);
@@ -2147,11 +2149,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree
status, tree label_finish,
pstat = status;
}
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_caf_deregister, 5,
- token, build_int_cst (integer_type_node,
- caf_dereg_type),
- pstat, null_pointer_node, integer_zero_node);
+ if (errmsg != NULL_TREE)
+ {
+ perrmsg = errmsg;
+ perrlen = errmsg_len;
+ }
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5,
+ token,
+ build_int_cst (integer_type_node,
+ caf_dereg_type),
+ pstat, perrmsg, perrlen);
gfc_add_expr_to_block (&non_null, tmp);
/* It guarantees memory consistency within the same segment. */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ae7be9f81a8c..13bb04af1d2c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -774,12 +774,13 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree,
tree, tree,
tree = NULL_TREE);
/* Generate code to deallocate an array. */
-tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
- gfc_expr *, int, tree = NULL_TREE,
- tree a = NULL_TREE, tree c = NULL_TREE);
-tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
+tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, gfc_expr
*,
+ int, tree = NULL_TREE, tree a = NULL_TREE,
+ tree c = NULL_TREE, bool u = false);
+tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr *,
gfc_typespec, tree = NULL_TREE,
- bool c = false);
+ bool c = false, bool u = false,
+ tree = NULL_TREE, tree = NULL_TREE);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);
diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_2.f90
b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90
new file mode 100644
index 000000000000..702611c35ab4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90
@@ -0,0 +1,30 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! Test critical syntax errors with stat= and errmsg= specifiers
+
+ implicit none
+ integer :: istat
+ character(len=30) :: err
+ integer(kind=1) :: too_small_stat
+
+ critical (stat=err) !{ dg-error "must be a scalar INTEGER" }
+ continue
+ end critical
+
+ critical (stat=istat, stat=istat) !{ dg-error "Duplicate STAT" }
+ continue
+ end critical !{ dg-error "Expecting END PROGRAM" }
+
+ critical (stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER
variable" }
+ continue
+ end critical
+
+ critical (stat=istat, errmsg=err, errmsg=err) !{ dg-error "Duplicate ERRMSG"
}
+ continue
+ end critical !{ dg-error "Expecting END PROGRAM" }
+
+ critical (stat=too_small_stat) !{ dg-error "scalar INTEGER variable of at
least kind 2" }
+ continue
+ end critical
+end
diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_3.f90
b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90
new file mode 100644
index 000000000000..cd609bd249dd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+! { dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Test critical construct with stat= and errmsg= specifiers
+!
+ use, intrinsic :: iso_fortran_env, only: int16
+ implicit none
+ integer :: istat = 42
+ integer(kind=int16) :: istat16 = 42
+ character(len=30) :: err = 'unchanged'
+ integer :: fail = 0
+
+ critical (stat=istat, errmsg=err)
+ if (istat /= 0) fail = 1
+ if (trim(err) /= 'unchanged') fail = 2
+ end critical
+
+ if (fail /= 0) stop fail
+
+ critical (stat=istat16, errmsg=err)
+ if (istat16 /= 0) fail = 3
+ if (trim(err) /= 'unchanged') fail = 4
+ end critical
+
+ if (fail /= 0) stop fail
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0,
1, 0B, &istat, &err, 30\\);" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0,
1, 0B, &stat\\.\[0-9\]+, &err, 30\\);" "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock
\\(caf_token\\.\[0-9\]+, 0, 1, &stat\\.\[0-9\]+, 0B, 0\\);" 2 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_11.f90
b/gcc/testsuite/gfortran.dg/move_alloc_11.f90
new file mode 100644
index 000000000000..d33e0ce7ed51
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_11.f90
@@ -0,0 +1,23 @@
+!{ dg-do compile }
+
+! General error checking for move_alloc parameter list.
+
+integer, allocatable :: i, o
+integer :: st, s2
+character(30) :: e, e2
+
+ call move_alloc(i, o, STAT=st)
+ call move_alloc(i, o, STAT=st, STAT=s2) !{ dg-error "Keyword 'stat' at
\\(1\\) has already appeared in the current argument list" }
+ call move_alloc(i, o, STAT=e) !{ dg-error "STAT= argument at \\(1\\) must be
a scalar INTEGER variable of at least kind 2" }
+ call move_alloc(i, o, STAT=[st, s2]) !{ dg-error "STAT= argument at \\(1\\)
must be a scalar INTEGER variable of at least kind 2" }
+ call move_alloc(i, o, STAT=.TRUE.) !{ dg-error "STAT= argument at \\(1\\)
must be a scalar INTEGER variable of at least kind 2" }
+
+ call move_alloc(i, o, STAT=st, ERRMSG=e)
+ call move_alloc(i, o, ERRMSG=e)
+ call move_alloc(i, o, ERRMSG=e, ERRMSG=e2) !{ dg-error "Keyword 'errmsg' at
\\(1\\) has already appeared in the current argument list" }
+ call move_alloc(i, o, ERRMSG=st) !{ dg-error "ERRMSG= argument at \\(1\\)
must be a scalar CHARACTER variable of at least kind 1" }
+ call move_alloc(i, o, ERRMSG=.TRUE.) !{ dg-error "ERRMSG= argument at
\\(1\\) must be a scalar CHARACTER variable of at least kind 1" }
+
+
+end
+
diff --git a/gcc/testsuite/gfortran.dg/team_sync_1.f90
b/gcc/testsuite/gfortran.dg/team_sync_1.f90
new file mode 100644
index 000000000000..5b28651b8be0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/team_sync_1.f90
@@ -0,0 +1,24 @@
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Test sync team syntax errors
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ integer :: istat
+ character(len=30) :: err
+ type(team_type) :: team
+
+ form team (mod(this_image(),2)+1, team)
+
+ change team (team)
+ sync team ! { dg-error "Syntax error in SYNC TEAM statement" }
+ sync team (err) ! { dg-error "must be a scalar expression of type
TEAM_TYPE" }
+ sync team (team, istat) ! { dg-error "Syntax error in SYNC TEAM statement"
}
+ sync team (team, stat=err) ! { dg-error "must be a scalar INTEGER" }
+ sync team (team, stat=istat, stat=istat) ! { dg-error "Duplicate STAT" }
+ sync team (team, stat=istat, errmsg=istat) ! { dg-error "must be a scalar
CHARACTER variable" }
+ sync team (team, stat=istat, errmsg=err, errmsg=err) ! { dg-error
"Duplicate ERRMSG" }
+ end team
+end
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 9c1c0c1bc8ca..1d7af6b89722 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -859,14 +859,14 @@ _gfortran_caf_lock (caf_token_t token, size_t index,
{
*acquired_lock = (int) false;
if (stat)
- *stat = 0;
- return;
+ *stat = GFC_STAT_LOCKED;
+ return;
}
if (stat)
{
- *stat = 1;
+ *stat = GFC_STAT_LOCKED;
if (errmsg_len > 0)
{
size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
@@ -899,7 +899,7 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
if (stat)
{
- *stat = 1;
+ *stat = GFC_STAT_UNLOCKED;
if (errmsg_len > 0)
{
size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
