Hi all,
this patch unifies handling of STAT= and ERRMSG= for some users of these
optional arguments. The first introduction of the arguments seems to stem from
SYNC, which choose the rule name sync_stat in the Fortran grammar. Therefore I
named the structure and participating routines the same. The patch allows for
easy parsing, resolving and translating these arguments. There is also an
implementation on how to make use of this for functions like MOVE_ALLOC(). The
following patches make use sync_stat in the teams statements.
Regtested ok on x86_64-pc-linux-gnu / F41. Ok for mainline?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From b329c2d35cbc4a5ecf0445811f1236ef3c9e9611 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Fri, 14 Mar 2025 14:20:18 +0100
Subject: [PATCH 1/6] 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.
---
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 +-
.../gfortran.dg/coarray_critical_2.f90 | 30 +++
.../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(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray_critical_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray_critical_3.f90
create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_11.f90
create mode 100644 gcc/testsuite/gfortran.dg/team_sync_1.f90
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 9c66c25e059..00342787a51 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 9501bccb803..4ace093738c 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 5ef70378b1b..46310a088f2 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 d2ce74f16eb..91f16c7f35f 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 fec1c24a099..70e14c4098b 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 ec9e5873204..4d77e094ab9 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 cdf043b6411..e69905ae1f7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11448,6 +11448,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)
@@ -11457,6 +11504,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;
@@ -13457,10 +13506,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 aea132ded13..96c4ba9d6c3 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 6ffc3e0261e..16ade8d4d55 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 94ecde096d5..cc3c344fd5f 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 67b1970776b..8fbcdcba1f9 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 b03dcc1fb1a..fdeb1e89a76 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 63a566ada22..9f8f4264e8b 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 00000000000..702611c35ab
--- /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 00000000000..cd609bd249d
--- /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 00000000000..d33e0ce7ed5
--- /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 00000000000..5b28651b8be
--- /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 9c1c0c1bc8c..1d7af6b8972 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
--
2.49.0
