Fortran/OpenMP: Support most of 5.1 atomic extensions
Implements moste of OpenMP 5.1 atomic extensions,
except that 'compare' is parsed but rejected during
resolution. (As the trans-openmp.c handling is missing.)
gcc/fortran/ChangeLog:
* dump-parse-tree.c (show_omp_clauses): Handle
weak/compare/fail clause.
* gfortran.h (gfc_omp_clauses): Add weak, compare, fail.
* openmp.c (enum omp_mask1, gfc_match_omp_clauses,
OMP_ATOMIC_CLAUSES): Update for new clauses.
(gfc_match_omp_atomic): Update for 5.1 atomic changes.
(is_conversion): Support widening in one go.
(is_scalar_intrinsic_expr): New.
(resolve_omp_atomic): Update for 5.1 atomic changes.
* parse.c (parse_omp_oacc_atomic): Update for compare.
* resolve.c (gfc_resolve_blocks): Update asserts.
* trans-openmp.c (gfc_trans_omp_atomic): Handle new clauses.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/atomic-2.f90: Move now supported code to ...
* gfortran.dg/gomp/atomic.f90: here.
* gfortran.dg/gomp/atomic-10.f90: New test.
* gfortran.dg/gomp/atomic-12.f90: New test.
* gfortran.dg/gomp/atomic-15.f90: New test.
* gfortran.dg/gomp/atomic-16.f90: New test.
* gfortran.dg/gomp/atomic-17.f90: New test.
* gfortran.dg/gomp/atomic-18.f90: New test.
* gfortran.dg/gomp/atomic-19.f90: New test.
* gfortran.dg/gomp/atomic-20.f90: New test.
* gfortran.dg/gomp/atomic-22.f90: New test.
* gfortran.dg/gomp/atomic-24.f90: New test.
* gfortran.dg/gomp/atomic-25.f90: New test.
* gfortran.dg/gomp/atomic-26.f90: New test.
libgomp/ChangeLog
* libgomp.texi (OpenMP 5.1): Update status.
gcc/fortran/dump-parse-tree.c | 20 +
gcc/fortran/gfortran.h | 3 +-
gcc/fortran/intrinsic.c | 2 +-
gcc/fortran/openmp.c | 584 +++++++++++++++++----------
gcc/fortran/parse.c | 19 +-
gcc/fortran/resolve.c | 9 +-
gcc/fortran/trans-openmp.c | 15 +-
gcc/testsuite/gfortran.dg/gomp/atomic-10.f90 | 32 ++
gcc/testsuite/gfortran.dg/gomp/atomic-12.f90 | 364 +++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/atomic-15.f90 | 44 ++
gcc/testsuite/gfortran.dg/gomp/atomic-16.f90 | 36 ++
gcc/testsuite/gfortran.dg/gomp/atomic-17.f90 | 41 ++
gcc/testsuite/gfortran.dg/gomp/atomic-18.f90 | 27 ++
gcc/testsuite/gfortran.dg/gomp/atomic-19.f90 | 39 ++
gcc/testsuite/gfortran.dg/gomp/atomic-2.f90 | 42 +-
gcc/testsuite/gfortran.dg/gomp/atomic-20.f90 | 39 ++
gcc/testsuite/gfortran.dg/gomp/atomic-22.f90 | 24 ++
gcc/testsuite/gfortran.dg/gomp/atomic-24.f90 | 13 +
gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 | 53 +++
gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 | 75 ++++
gcc/testsuite/gfortran.dg/gomp/atomic.f90 | 40 +-
gcc/testsuite/gfortran.dg/gomp/atomic2.f90 | 0
22 files changed, 1256 insertions(+), 265 deletions(-)
@@ -1810,6 +1810,10 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
}
fputc (')', dumpfile);
}
+ if (omp_clauses->weak)
+ fputs (" WEAK", dumpfile);
+ if (omp_clauses->compare)
+ fputs (" COMPARE", dumpfile);
if (omp_clauses->nogroup)
fputs (" NOGROUP", dumpfile);
if (omp_clauses->simd)
@@ -1926,6 +1930,22 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
fputc (' ', dumpfile);
fputs (memorder, dumpfile);
}
+ if (omp_clauses->fail != OMP_MEMORDER_UNSET)
+ {
+ const char *memorder;
+ switch (omp_clauses->fail)
+ {
+ case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break;
+ case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
+ case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
+ case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break;
+ case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
+ default: gcc_unreachable ();
+ }
+ fputs (" FAIL(", dumpfile);
+ fputs (memorder, dumpfile);
+ putc (')', dumpfile);
+ }
if (omp_clauses->at != OMP_AT_UNSET)
{
if (omp_clauses->at != OMP_AT_COMPILATION)
@@ -1526,10 +1526,11 @@ typedef struct gfc_omp_clauses
unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1;
unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1;
unsigned order_unconstrained:1, order_reproducible:1, capture:1;
- unsigned grainsize_strict:1, num_tasks_strict:1;
+ unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1;
ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
ENUM_BITFIELD (gfc_omp_device_type) device_type:2;
ENUM_BITFIELD (gfc_omp_memorder) memorder:3;
+ ENUM_BITFIELD (gfc_omp_memorder) fail:3;
ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3;
ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3;
ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3;
@@ -2029,7 +2029,7 @@ add_functions (void)
add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL,
ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018,
- gfc_check_get_team, NULL, gfc_resolve_get_team,
+ gfc_check_get_team, gfc_simplify_get_team, gfc_resolve_get_team,
level, BT_INTEGER, di, OPTIONAL);
add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
@@ -917,6 +917,9 @@ enum omp_mask1
OMP_CLAUSE_AT, /* OpenMP 5.1. */
OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
+ OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
+ OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
+ OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
@@ -1449,8 +1452,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
*cp = NULL;
while (1)
- {
- if ((first || gfc_match_char (',') != MATCH_YES)
+ {
+ match m = MATCH_NO;
+ if ((first || (m = gfc_match_char (',')) != MATCH_YES)
&& (needs_space && gfc_match_space () != MATCH_YES))
break;
needs_space = false;
@@ -1460,7 +1464,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
gfc_omp_namelist **head;
old_loc = gfc_current_locus;
char pc = gfc_peek_ascii_char ();
- match m;
+ if (pc == '\n' && m == MATCH_YES)
+ {
+ gfc_error ("Clause expected at %C after tailing comma");
+ goto error;
+ }
switch (pc)
{
case 'a':
@@ -1654,6 +1662,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
continue;
}
}
+ if ((mask & OMP_CLAUSE_COMPARE)
+ && (m = gfc_match_dupl_check (!c->compare, "compare"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->compare = true;
+ needs_space = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
@@ -2009,6 +2027,27 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
break;
case 'f':
+ if ((mask & OMP_CLAUSE_FAIL)
+ && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
+ "fail", true)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ if (gfc_match ("seq_cst") == MATCH_YES)
+ c->fail = OMP_MEMORDER_SEQ_CST;
+ else if (gfc_match ("acquire") == MATCH_YES)
+ c->fail = OMP_MEMORDER_ACQUIRE;
+ else if (gfc_match ("relaxed") == MATCH_YES)
+ c->fail = OMP_MEMORDER_RELAXED;
+ else
+ {
+ gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
+ break;
+ }
+ if (gfc_match (" )") != MATCH_YES)
+ goto error;
+ continue;
+ }
if ((mask & OMP_CLAUSE_FILTER)
&& (m = gfc_match_dupl_check (!c->filter, "filter", true,
&c->filter)) != MATCH_NO)
@@ -2903,6 +2942,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
continue;
}
+ if ((mask & OMP_CLAUSE_WEAK)
+ && (m = gfc_match_dupl_check (!c->weak, "weak"))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ c->weak = true;
+ needs_space = true;
+ continue;
+ }
if ((mask & OMP_CLAUSE_WORKER)
&& (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
{
@@ -3592,7 +3641,8 @@ cleanup:
(omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)
#define OMP_ATOMIC_CLAUSES \
(omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
- | OMP_CLAUSE_MEMORDER)
+ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
+ | OMP_CLAUSE_WEAK)
#define OMP_MASKED_CLAUSES \
(omp_mask (OMP_CLAUSE_FILTER))
#define OMP_ERROR_CLAUSES \
@@ -5717,6 +5767,7 @@ gfc_match_omp_ordered_depend (void)
- capture
- memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
- hint(hint-expr)
+ - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
*/
match
@@ -5728,12 +5779,25 @@ gfc_match_omp_atomic (void)
if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
return MATCH_ERROR;
- if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UNSET)
- gfc_error ("OMP ATOMIC at %L with multiple atomic clauses", &loc);
-
if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
+ if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "CAPTURE");
+ if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "COMPARE");
+ if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
+ gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
+ "READ or WRITE", &loc, "FAIL");
+ if (c->weak && !c->compare)
+ {
+ gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
+ "WEAK", "COMPARE");
+ c->weak = false;
+ }
+
if (c->memorder == OMP_MEMORDER_UNSET)
{
gfc_namespace *prog_unit = gfc_current_ns;
@@ -5764,32 +5828,24 @@ gfc_match_omp_atomic (void)
switch (c->atomic_op)
{
case GFC_OMP_ATOMIC_READ:
- if (c->memorder == OMP_MEMORDER_ACQ_REL
- || c->memorder == OMP_MEMORDER_RELEASE)
+ if (c->memorder == OMP_MEMORDER_RELEASE)
{
gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
- "ACQ_REL or RELEASE clauses", &loc);
+ "RELEASE clause", &loc);
c->memorder = OMP_MEMORDER_SEQ_CST;
}
+ else if (c->memorder == OMP_MEMORDER_ACQ_REL)
+ c->memorder = OMP_MEMORDER_ACQUIRE;
break;
case GFC_OMP_ATOMIC_WRITE:
- if (c->memorder == OMP_MEMORDER_ACQ_REL
- || c->memorder == OMP_MEMORDER_ACQUIRE)
+ if (c->memorder == OMP_MEMORDER_ACQUIRE)
{
gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
- "ACQ_REL or ACQUIRE clauses", &loc);
- c->memorder = OMP_MEMORDER_SEQ_CST;
- }
- break;
- case GFC_OMP_ATOMIC_UPDATE:
- if ((c->memorder == OMP_MEMORDER_ACQ_REL
- || c->memorder == OMP_MEMORDER_ACQUIRE)
- && !c->capture)
- {
- gfc_error ("!$OMP ATOMIC UPDATE at %L incompatible with "
- "ACQ_REL or ACQUIRE clauses", &loc);
+ "ACQUIRE clause", &loc);
c->memorder = OMP_MEMORDER_SEQ_CST;
}
+ else if (c->memorder == OMP_MEMORDER_ACQ_REL)
+ c->memorder = OMP_MEMORDER_RELEASE;
break;
default:
break;
@@ -7450,20 +7506,24 @@ expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
/* If EXPR is a conversion function that widens the type
- if WIDENING is true or narrows the type if WIDENING is false,
+ if WIDENING is true or narrows the type if NARROW is true,
return the inner expression, otherwise return NULL. */
static gfc_expr *
-is_conversion (gfc_expr *expr, bool widening)
+is_conversion (gfc_expr *expr, bool narrowing, bool widening)
{
gfc_typespec *ts1, *ts2;
if (expr->expr_type != EXPR_FUNCTION
|| expr->value.function.isym == NULL
|| expr->value.function.esym != NULL
- || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
+ || expr->value.function.isym->id != GFC_ISYM_CONVERSION
+ || (!narrowing && !widening))
return NULL;
+ if (narrowing && widening)
+ return expr->value.function.actual->expr;
+
if (widening)
{
ts1 = &expr->ts;
@@ -7482,163 +7542,297 @@ is_conversion (gfc_expr *expr, bool widening)
return NULL;
}
+static bool
+is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
+{
+ if (must_be_var
+ && (expr->expr_type != EXPR_VARIABLE || !expr->symtree)
+ && (!conv_ok || !is_conversion (expr, true, true)))
+ return false;
+ return (expr->rank == 0
+ && !gfc_is_coindexed (expr)
+ && (expr->ts.type != BT_INTEGER
+ || expr->ts.type != BT_REAL
+ || expr->ts.type != BT_COMPLEX
+ || expr->ts.type != BT_LOGICAL));
+}
-static void
+/*static */ void
resolve_omp_atomic (gfc_code *code)
{
gfc_code *atomic_code = code->block;
gfc_symbol *var;
- gfc_expr *expr2, *expr2_tmp;
+ gfc_expr *stmt_expr2, *capt_expr2;
gfc_omp_atomic_op aop
= (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
& GFC_OMP_ATOMIC_MASK);
+ gfc_code *stmt = NULL, *capture_stmt = NULL;
+ gfc_expr *comp_cond = NULL;
+ locus *loc = NULL;
code = code->block->next;
- /* resolve_blocks asserts this is initially EXEC_ASSIGN.
+ /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
If it changed to EXEC_NOP, assume an error has been emitted already. */
- if (code->op == EXEC_NOP)
+ if (code->op == EXEC_NOP /* FIXME: || (code->next && code->next->op == EXEC_NOP)*/)
return;
- if (code->op != EXEC_ASSIGN)
+
+ if (code->op == EXEC_IF && code->block->op == EXEC_IF)
+ comp_cond = code->block->expr1;
+
+ if (atomic_code->ext.omp_clauses->compare
+ && atomic_code->ext.omp_clauses->capture)
{
- unexpected:
- gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
- return;
+ /* Must be either "if (x == e) then; x = d; else; v = x; end if"
+ or "v = expr" followed/preceded by
+ "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
+ gfc_code *next = code;
+ if (code->op == EXEC_ASSIGN)
+ {
+ capture_stmt = code;
+ next = code->next;
+ }
+ if (next->op == EXEC_IF
+ && next->block
+ && next->block->op == EXEC_IF
+ && next->block->next->op == EXEC_ASSIGN)
+ {
+ stmt = next->block->next;
+ if (stmt->next)
+ {
+ loc = &stmt->loc;
+ goto unexpected;
+ }
+ }
+ if (stmt && !capture_stmt && next->block->block)
+ {
+ if (next->block->block->expr1)
+ {
+ gfc_error ("Expected ELSE at %L in atomic compare capture",
+ &next->block->block->expr1->where);
+ }
+ if (!code->block->block->next
+ || code->block->block->next->op != EXEC_ASSIGN)
+ {
+ loc = (code->block->block->next ? &code->block->block->next->loc
+ : &code->block->block->loc);
+ goto unexpected;
+ }
+ capture_stmt = code->block->block->next;
+ if (capture_stmt->next)
+ {
+ loc = &capture_stmt->next->loc;
+ goto unexpected;
+ }
+ }
+ if (stmt && !capture_stmt && code->op == EXEC_ASSIGN)
+ {
+ capture_stmt = code;
+ }
+ else if (!capture_stmt)
+ {
+ loc = &code->loc;
+ goto unexpected;
+ }
+ }
+ else if (atomic_code->ext.omp_clauses->compare)
+ {
+ /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
+ if (code->op == EXEC_IF
+ && code->block
+ && code->block->op == EXEC_IF
+ && code->block->next->op == EXEC_ASSIGN)
+ {
+ stmt = code->block->next;
+ if (stmt->next || code->block->block)
+ {
+ loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
+ goto unexpected;
+ }
+ }
+ else
+ {
+ loc = &code->loc;
+ goto unexpected;
+ }
}
- if (!atomic_code->ext.omp_clauses->capture)
+ else if (atomic_code->ext.omp_clauses->capture)
{
- if (code->next != NULL)
+ /* Must be: "v = x" followed/preceded by "x = ...". */
+ if (code->op != EXEC_ASSIGN)
goto unexpected;
+ if (code->next->op != EXEC_ASSIGN)
+ {
+ loc = &code->next->loc;
+ goto unexpected;
+ }
+ gfc_expr *expr2, *expr2_next;
+ expr2 = is_conversion (code->expr2, true, true);
+ if (expr2 == NULL)
+ expr2 = code->expr2;
+ expr2_next = is_conversion (code->next->expr2, true, true);
+ if (expr2_next == NULL)
+ expr2_next = code->next->expr2;
+ if (code->expr1->expr_type == EXPR_VARIABLE
+ && code->next->expr1->expr_type == EXPR_VARIABLE
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2_next->expr_type == EXPR_VARIABLE)
+ {
+ if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
+ {
+ stmt = code;
+ capture_stmt = code->next;
+ }
+ else
+ {
+ capture_stmt = code;
+ stmt = code->next;
+ }
+ }
+ else if (expr2->expr_type == EXPR_VARIABLE)
+ {
+ capture_stmt = code;
+ stmt = code->next;
+ }
+ else
+ {
+ stmt = code;
+ capture_stmt = code->next;
+ }
+ gcc_assert (!code->next->next);
}
else
{
- if (code->next == NULL)
+ /* x = ... */
+ stmt = code;
+ if ((!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
+ || (atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_IF))
goto unexpected;
- if (code->next->op == EXEC_NOP)
- return;
- if (code->next->op != EXEC_ASSIGN || code->next->next)
+ gcc_assert (!code->next);
+ }
+
+ if (comp_cond)
+ {
+ if (comp_cond->expr_type != EXPR_OP
+ || (comp_cond->value.op.op != INTRINSIC_EQ
+ && comp_cond->value.op.op != INTRINSIC_EQ_OS
+ && comp_cond->value.op.op != INTRINSIC_EQV))
{
- code = code->next;
- goto unexpected;
+ gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
+ "expression at %L", &comp_cond->where);
+ return;
+ }
+ if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, false))
+ {
+ gfc_error ("Expected scalar intrinsic variable at %L in atomic "
+ "comparison", &comp_cond->value.op.op1->where);
+ return;
+ }
+ if (!gfc_resolve_expr (comp_cond->value.op.op2)
+ || !is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
+ {
+ gfc_error ("Expected scalar intrinsic expression at %L in atomic "
+ "comparison", &comp_cond->value.op.op1->where);
+ return;
}
}
- if (code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->symtree == NULL
- || code->expr1->rank != 0
- || (code->expr1->ts.type != BT_INTEGER
- && code->expr1->ts.type != BT_REAL
- && code->expr1->ts.type != BT_COMPLEX
- && code->expr1->ts.type != BT_LOGICAL))
+ if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
- "intrinsic type at %L", &code->loc);
+ "intrinsic type at %L", &stmt->expr1->where);
return;
}
- var = code->expr1->symtree->n.sym;
- expr2 = is_conversion (code->expr2, false);
- if (expr2 == NULL)
+ if (!gfc_resolve_expr (stmt->expr2)
+ || !is_scalar_intrinsic_expr (stmt->expr2, false, false))
{
- if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
- expr2 = is_conversion (code->expr2, true);
- if (expr2 == NULL)
- expr2 = code->expr2;
+ gfc_error ("!$OMP ATOMIC statement must assign an expression of "
+ "intrinsic type at %L", &stmt->expr2->where);
+ return;
}
+ if (gfc_expr_attr (stmt->expr1).allocatable)
+ {
+ gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
+ &stmt->expr1->where);
+ return;
+ }
+
+ var = stmt->expr1->symtree->n.sym;
+ stmt_expr2 = is_conversion (stmt->expr2, true, true);
+ if (stmt_expr2 == NULL)
+ stmt_expr2 = stmt->expr2;
+
switch (aop)
{
case GFC_OMP_ATOMIC_READ:
- if (expr2->expr_type != EXPR_VARIABLE
- || expr2->symtree == NULL
- || expr2->rank != 0
- || (expr2->ts.type != BT_INTEGER
- && expr2->ts.type != BT_REAL
- && expr2->ts.type != BT_COMPLEX
- && expr2->ts.type != BT_LOGICAL))
+ if (stmt_expr2->expr_type != EXPR_VARIABLE)
gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
- "variable of intrinsic type at %L", &expr2->where);
+ "variable of intrinsic type at %L", &stmt_expr2->where);
return;
case GFC_OMP_ATOMIC_WRITE:
- if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
+ if (expr_references_sym (stmt_expr2, var, NULL))
gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
"must be scalar and cannot reference var at %L",
- &expr2->where);
+ &stmt_expr2->where);
return;
default:
break;
}
+
+ if (atomic_code->ext.omp_clauses->compare
+ && !atomic_code->ext.omp_clauses->capture)
+ {
+ gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet "
+ "supported", &atomic_code->loc);
+ return;
+ }
+
if (atomic_code->ext.omp_clauses->capture)
{
- expr2_tmp = expr2;
- if (expr2 == code->expr2)
+ if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
{
- expr2_tmp = is_conversion (code->expr2, true);
- if (expr2_tmp == NULL)
- expr2_tmp = expr2;
+ gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
+ "variable of intrinsic type at %L",
+ &capture_stmt->expr1->where);
+ return;
}
- if (expr2_tmp->expr_type == EXPR_VARIABLE)
+
+ if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
{
- if (expr2_tmp->symtree == NULL
- || expr2_tmp->rank != 0
- || (expr2_tmp->ts.type != BT_INTEGER
- && expr2_tmp->ts.type != BT_REAL
- && expr2_tmp->ts.type != BT_COMPLEX
- && expr2_tmp->ts.type != BT_LOGICAL)
- || expr2_tmp->symtree->n.sym == var)
- {
- gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
- "a scalar variable of intrinsic type at %L",
- &expr2_tmp->where);
- return;
- }
- var = expr2_tmp->symtree->n.sym;
- code = code->next;
- if (code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->symtree == NULL
- || code->expr1->rank != 0
- || (code->expr1->ts.type != BT_INTEGER
- && code->expr1->ts.type != BT_REAL
- && code->expr1->ts.type != BT_COMPLEX
- && code->expr1->ts.type != BT_LOGICAL))
- {
- gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
- "a scalar variable of intrinsic type at %L",
- &code->expr1->where);
- return;
- }
- if (code->expr1->symtree->n.sym != var)
- {
- gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
- "different variable than update statement writes "
- "into at %L", &code->expr1->where);
- return;
- }
- expr2 = is_conversion (code->expr2, false);
- if (expr2 == NULL)
- expr2 = code->expr2;
+ gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
+ " of intrinsic type at %L", &capture_stmt->expr2->where);
+ return;
}
- }
+ capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
+ if (capt_expr2 == NULL)
+ capt_expr2 = capture_stmt->expr2;
- if (gfc_expr_attr (code->expr1).allocatable)
- {
- gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
- &code->loc);
- return;
+ if (capt_expr2->symtree->n.sym != var)
+ {
+ gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
+ "different variable than update statement writes "
+ "into at %L", &capture_stmt->expr2->where);
+ return;
+ }
}
if (atomic_code->ext.omp_clauses->capture
- && code->next == NULL
- && code->expr2->rank == 0
- && !expr_references_sym (code->expr2, var, NULL))
+ && !expr_references_sym (stmt_expr2, var, NULL))
atomic_code->ext.omp_clauses->atomic_op
= (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
| GFC_OMP_ATOMIC_SWAP);
- else if (expr2->expr_type == EXPR_OP)
+ else if (stmt_expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
- gfc_intrinsic_op op = expr2->value.op.op;
+ gfc_intrinsic_op op = stmt_expr2->value.op.op;
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
+ if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET
+ && !atomic_code->ext.omp_clauses->compare)
+ gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
+ " the COMPARE clause or using the intrinsic MIN/MAX "
+ "procedure", &atomic_code->loc);
switch (op)
{
case INTRINSIC_PLUS:
@@ -7665,7 +7859,7 @@ resolve_omp_atomic (gfc_code *code)
default:
gfc_error ("!$OMP ATOMIC assignment operator must be binary "
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
- &expr2->where);
+ &stmt_expr2->where);
return;
}
@@ -7675,12 +7869,12 @@ resolve_omp_atomic (gfc_code *code)
(expr) op var. We rely here on the fact that the matcher
for x op1 y op2 z where op1 and op2 have equal precedence
returns (x op1 y) op2 z. */
- e = expr2->value.op.op2;
+ e = stmt_expr2->value.op.op2;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
v = e;
- else if ((c = is_conversion (e, true)) != NULL
+ else if ((c = is_conversion (e, false, true)) != NULL
&& c->expr_type == EXPR_VARIABLE
&& c->symtree != NULL
&& c->symtree->n.sym == var)
@@ -7688,7 +7882,7 @@ resolve_omp_atomic (gfc_code *code)
else
{
gfc_expr **p = NULL, **q;
- for (q = &expr2->value.op.op1; (e = *q) != NULL; )
+ for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
@@ -7696,7 +7890,7 @@ resolve_omp_atomic (gfc_code *code)
v = e;
break;
}
- else if ((c = is_conversion (e, true)) != NULL)
+ else if ((c = is_conversion (e, false, true)) != NULL)
q = &e->value.function.actual->expr;
else if (e->expr_type != EXPR_OP
|| (e->value.op.op != op
@@ -7712,7 +7906,7 @@ resolve_omp_atomic (gfc_code *code)
if (v == NULL)
{
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
- "or var = expr op var at %L", &expr2->where);
+ "or var = expr op var at %L", &stmt_expr2->where);
return;
}
@@ -7727,7 +7921,7 @@ resolve_omp_atomic (gfc_code *code)
case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not "
"mathematically equivalent to var = var op "
- "(expr) at %L", &expr2->where);
+ "(expr) at %L", &stmt_expr2->where);
break;
default:
break;
@@ -7735,43 +7929,44 @@ resolve_omp_atomic (gfc_code *code)
/* Canonicalize into var = var op (expr). */
*p = e->value.op.op2;
- e->value.op.op2 = expr2;
- e->ts = expr2->ts;
- if (code->expr2 == expr2)
- code->expr2 = expr2 = e;
+ e->value.op.op2 = stmt_expr2;
+ e->ts = stmt_expr2->ts;
+ if (stmt->expr2 == stmt_expr2)
+ stmt->expr2 = stmt_expr2 = e;
else
- code->expr2->value.function.actual->expr = expr2 = e;
+ stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
- if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
+ if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
+ &stmt_expr2->ts))
{
- for (p = &expr2->value.op.op1; *p != v;
+ for (p = &stmt_expr2->value.op.op1; *p != v;
p = &(*p)->value.function.actual->expr)
;
*p = NULL;
- gfc_free_expr (expr2->value.op.op1);
- expr2->value.op.op1 = v;
- gfc_convert_type (v, &expr2->ts, 2);
+ gfc_free_expr (stmt_expr2->value.op.op1);
+ stmt_expr2->value.op.op1 = v;
+ gfc_convert_type (v, &stmt_expr2->ts, 2);
}
}
}
- if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
+ if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
{
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
"must be scalar and cannot reference var at %L",
- &expr2->where);
+ &stmt_expr2->where);
return;
}
}
- else if (expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL
- && expr2->value.function.esym == NULL
- && expr2->value.function.actual != NULL
- && expr2->value.function.actual->next != NULL)
+ else if (stmt_expr2->expr_type == EXPR_FUNCTION
+ && stmt_expr2->value.function.isym != NULL
+ && stmt_expr2->value.function.esym == NULL
+ && stmt_expr2->value.function.actual != NULL
+ && stmt_expr2->value.function.actual->next != NULL)
{
gfc_actual_arglist *arg, *var_arg;
- switch (expr2->value.function.isym->id)
+ switch (stmt_expr2->value.function.isym->id)
{
case GFC_ISYM_MIN:
case GFC_ISYM_MAX:
@@ -7779,31 +7974,37 @@ resolve_omp_atomic (gfc_code *code)
case GFC_ISYM_IAND:
case GFC_ISYM_IOR:
case GFC_ISYM_IEOR:
- if (expr2->value.function.actual->next->next != NULL)
+ if (stmt_expr2->value.function.actual->next->next != NULL)
{
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
"or IEOR must have two arguments at %L",
- &expr2->where);
+ &stmt_expr2->where);
return;
}
break;
default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
"MIN, MAX, IAND, IOR or IEOR at %L",
- &expr2->where);
+ &stmt_expr2->where);
return;
}
var_arg = NULL;
- for (arg = expr2->value.function.actual; arg; arg = arg->next)
- {
- if ((arg == expr2->value.function.actual
- || (var_arg == NULL && arg->next == NULL))
- && arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->symtree != NULL
- && arg->expr->symtree->n.sym == var)
- var_arg = arg;
- else if (expr_references_sym (arg->expr, var, NULL))
+ for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
+ {
+ gfc_expr *e = NULL;
+ if (arg == stmt_expr2->value.function.actual
+ || (var_arg == NULL && arg->next == NULL))
+ {
+ e = is_conversion (arg->expr, false, true);
+ if (!e)
+ e = arg->expr;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree != NULL
+ && e->symtree->n.sym == var)
+ var_arg = arg;
+ }
+ if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
{
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
"not reference %qs at %L",
@@ -7821,72 +8022,35 @@ resolve_omp_atomic (gfc_code *code)
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
- "be %qs at %L", var->name, &expr2->where);
+ "be %qs at %L", var->name, &stmt_expr2->where);
return;
}
- if (var_arg != expr2->value.function.actual)
+ if (var_arg != stmt_expr2->value.function.actual)
{
/* Canonicalize, so that var comes first. */
gcc_assert (var_arg->next == NULL);
- for (arg = expr2->value.function.actual;
+ for (arg = stmt_expr2->value.function.actual;
arg->next != var_arg; arg = arg->next)
;
- var_arg->next = expr2->value.function.actual;
- expr2->value.function.actual = var_arg;
+ var_arg->next = stmt_expr2->value.function.actual;
+ stmt_expr2->value.function.actual = var_arg;
arg->next = NULL;
}
}
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or "
- "intrinsic on right hand side at %L", &expr2->where);
-
- if (atomic_code->ext.omp_clauses->capture && code->next)
- {
- code = code->next;
- if (code->expr1->expr_type != EXPR_VARIABLE
- || code->expr1->symtree == NULL
- || code->expr1->rank != 0
- || (code->expr1->ts.type != BT_INTEGER
- && code->expr1->ts.type != BT_REAL
- && code->expr1->ts.type != BT_COMPLEX
- && code->expr1->ts.type != BT_LOGICAL))
- {
- gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
- "a scalar variable of intrinsic type at %L",
- &code->expr1->where);
- return;
- }
+ "intrinsic on right hand side at %L", &stmt_expr2->where);
- expr2 = is_conversion (code->expr2, false);
- if (expr2 == NULL)
- {
- expr2 = is_conversion (code->expr2, true);
- if (expr2 == NULL)
- expr2 = code->expr2;
- }
+ if (atomic_code->ext.omp_clauses->compare)
+ gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet "
+ "supported", &atomic_code->loc);
+ return;
- if (expr2->expr_type != EXPR_VARIABLE
- || expr2->symtree == NULL
- || expr2->rank != 0
- || (expr2->ts.type != BT_INTEGER
- && expr2->ts.type != BT_REAL
- && expr2->ts.type != BT_COMPLEX
- && expr2->ts.type != BT_LOGICAL))
- {
- gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
- "from a scalar variable of intrinsic type at %L",
- &expr2->where);
- return;
- }
- if (expr2->symtree->n.sym != var)
- {
- gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
- "different variable than update statement writes "
- "into at %L", &expr2->where);
- return;
- }
- }
+unexpected:
+ gfc_error ("unexpected !$OMP ATOMIC expression at %L",
+ loc ? loc : &code->loc);
+ return;
}
@@ -5313,7 +5313,22 @@ parse_omp_oacc_atomic (bool omp_p)
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
- else if (st == ST_ASSIGNMENT)
+ else if (np->ext.omp_clauses->compare
+ && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
+ {
+ count--;
+ if (st == ST_IF_BLOCK)
+ {
+ parse_if_block ();
+ /* With else (or elseif). */
+ if (gfc_state_stack->tail->block->block)
+ count--;
+ }
+ accept_statement (st);
+ }
+ else if (st == ST_ASSIGNMENT
+ && (!np->ext.omp_clauses->compare
+ || np->ext.omp_clauses->capture))
{
accept_statement (st);
count--;
@@ -5332,8 +5347,6 @@ parse_omp_oacc_atomic (bool omp_p)
gfc_warning_check ();
st = next_statement ();
}
- else if (np->ext.omp_clauses->capture)
- gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
return st;
}
@@ -10848,13 +10848,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
/* Verify this before calling gfc_resolve_code, which might
change it. */
- gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
- gcc_assert ((!b->ext.omp_clauses->capture
- && b->next->next == NULL)
- || (b->ext.omp_clauses->capture
- && b->next->next != NULL
- && b->next->next->op == EXEC_ASSIGN
- && b->next->next->next == NULL));
+ gcc_assert (b->op == EXEC_OMP_ATOMIC
+ || b->next && b->next->op == EXEC_ASSIGN);
}
break;
@@ -4497,7 +4497,7 @@ gfc_trans_omp_atomic (gfc_code *code)
enum tree_code op = ERROR_MARK;
enum tree_code aop = OMP_ATOMIC;
bool var_on_left = false;
- enum omp_memory_order mo;
+ enum omp_memory_order mo, fail_mo;
switch (atomic_code->ext.omp_clauses->memorder)
{
case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
@@ -4508,6 +4508,17 @@ gfc_trans_omp_atomic (gfc_code *code)
case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
default: gcc_unreachable ();
}
+ switch (atomic_code->ext.omp_clauses->fail)
+ {
+ case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
+ case OMP_MEMORDER_ACQ_REL: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
+ case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
+ case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
+ case OMP_MEMORDER_RELEASE: fail_mo = OMP_FAIL_MEMORY_ORDER_RELEASE; break;
+ case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
+ default: gcc_unreachable ();
+ }
+ mo = (omp_memory_order) (mo | fail_mo);
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
@@ -4738,6 +4749,7 @@ gfc_trans_omp_atomic (gfc_code *code)
{
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
+ OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
gfc_add_expr_to_block (&block, x);
}
else
@@ -4761,6 +4773,7 @@ gfc_trans_omp_atomic (gfc_code *code)
}
x = build2 (aop, type, lhsaddr, convert (type, x));
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
+ OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
x = convert (TREE_TYPE (vse.expr), x);
gfc_add_modify (&block, vse.expr, x);
}
new file mode 100644
@@ -0,0 +1,32 @@
+! PR middle-end/28046 for the original C tet.
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-ompexp" }
+! { dg-require-effective-target cas_int }
+
+module m
+ implicit none
+ integer a(3), b
+ type t_C
+ integer :: x, y
+ end type
+ type(t_C) :: c
+
+ interface
+ integer function bar(); end
+ integer function baz(); end
+ end interface
+ pointer :: baz
+contains
+subroutine foo
+!$omp atomic
+ a(2) = a(2) + bar ()
+!$omp atomic
+ b = b + bar ()
+!$omp atomic
+ c%y = c%y + bar ()
+!$omp atomic
+ b = b + baz ()
+end
+end module
+
+! { dg-final { scan-tree-dump-times "__atomic_fetch_add" 4 "ompexp" } }
new file mode 100644
@@ -0,0 +1,364 @@
+! PR middle-end/45423 - for the original C/C++ testcase
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-gimple -g0 -Wno-deprecated" }
+! atomicvar should never be referenced in between the barrier and
+! following #pragma omp atomic_load.
+! { dg-final { scan-tree-dump-not "barrier\[^#\]*atomicvar" "gimple" } }
+
+module m
+ implicit none
+ logical :: atomicvar, c
+ integer :: i, atomicvar2, c2
+contains
+integer function foo ()
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .or. .true.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .or. .false.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .or. c
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .and. .true.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .and. .false.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .and. c
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .neqv. .true.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .neqv. .false.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .neqv. c
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .eqv. .true.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .eqv. .false.
+ !$omp barrier
+ !$omp atomic
+ atomicvar = atomicvar .eqv. c
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .true. .or. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .false. .or. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = c .or. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .true. .and. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .false. .and. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = c .and. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .true. .neqv. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .false. .neqv. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = c .neqv. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .true. .eqv. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = .false. .eqv. atomicvar
+ !$omp barrier
+ !$omp atomic
+ atomicvar = c .eqv. atomicvar
+ !$omp barrier
+ foo = 0
+end
+
+integer function bar ()
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (atomicvar2, -1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (atomicvar2, 0)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (atomicvar2, 1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (atomicvar2, 2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (atomicvar2, c2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (-1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (0, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (c2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (atomicvar2, -1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (atomicvar2, 0)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (atomicvar2, 1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (atomicvar2, 2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (atomicvar2, c2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (-1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (0, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ieor (1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = ior (c2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (atomicvar2, -1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (atomicvar2, 0)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (atomicvar2, 1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (atomicvar2, 2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (atomicvar2, c2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (-1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (0, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = iand (c2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (atomicvar2, -1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (atomicvar2, 0)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (atomicvar2, 1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (atomicvar2, 2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (atomicvar2, c2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (-1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (0, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = min (c2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (atomicvar2, -1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (atomicvar2, 0)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (atomicvar2, 1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (atomicvar2, 2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (atomicvar2, c2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (-1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (0, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (1, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = max (c2, atomicvar2)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 + (-1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 + 0
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 + 1
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 + 2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 + c2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = -1 + atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 0 + atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 1 + atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 2 + atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = c2 + atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 - (-1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 - 0
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 - 1
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 - 2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 - c2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = -1 - atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 0 - atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 1 - atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 2 - atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = c2 - atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 * (-1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 * 0
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 * 1
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 * 2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 * c2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = (-1) * atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 0 * atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 1 * atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 2 * atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = c2 * atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 / (-1)
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 / 0
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 / 1
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 / 2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = atomicvar2 / c2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = (-1) / atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 0 / atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 1 / atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = 2 / atomicvar2
+ !$omp barrier
+ !$omp atomic
+ atomicvar2 = c2 / atomicvar2
+ !$omp barrier
+ bar = 0
+end
+end module
new file mode 100644
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+module m
+ implicit none
+ integer :: x = 6
+end module m
+
+program main
+ use m
+ implicit none
+ integer v
+ !$omp atomic
+ x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" }
+ !$omp atomic
+ x = ieor (x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+ !$omp atomic update
+ x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic
+ x = ior (ieor (x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+ !$omp atomic
+ x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic
+ x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic capture
+ v = x; x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" }
+ !$omp atomic capture
+ v = x; x = ieor(x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+ !$omp atomic capture
+ v = x; x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic capture
+ v = x; x = ior (ieor(x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+ !$omp atomic capture
+ v = x; x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic capture
+ v = x; x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic capture
+ x = x * 7 + 6; v = x ! { dg-error "assignment must be var = var op expr or var = expr op var" }
+ !$omp atomic capture
+ x = ieor(x * 7, 6); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+ !$omp atomic capture
+ x = x - 8 + 6; v = x ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
+ !$omp atomic capture
+ x = ior(ieor(x, 7), 2); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" }
+end
new file mode 100644
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+module m
+ implicit none
+ integer :: x = 6
+contains
+
+subroutine foo ()
+ integer v
+ !$omp atomic seq_cst read
+ v = x
+ !$omp atomic seq_cst, read
+ v = x
+ !$omp atomic seq_cst write
+ x = v
+ !$omp atomic seq_cst ,write
+ x = v
+ !$omp atomic seq_cst update
+ x = x + v;
+ !$omp atomic seq_cst , update
+ x = v + x;
+ !$omp atomic seq_cst capture
+ v = x; x = x + 2;
+ !$omp atomic seq_cst, capture
+ v = x; x = 2 + x;
+ !$omp atomic read , seq_cst
+ v = x
+ !$omp atomic write ,seq_cst
+ x = v
+ !$omp atomic update, seq_cst
+ x = x + v
+ !$omp atomic capture, seq_cst
+ x = x + 2; v = x
+end
+end module m
new file mode 100644
@@ -0,0 +1,41 @@
+module m
+implicit none
+integer i, v
+real f
+contains
+
+subroutine foo ()
+ !$omp atomic release, hint (0), update
+ i = i + 1
+ !$omp atomic hint(0)seq_cst
+ i = i + 1
+ !$omp atomic relaxed,update,hint (0)
+ i = i + 1
+ !$omp atomic release
+ i = i + 1
+ !$omp atomic relaxed
+ i = i + 1
+ !$omp atomic acq_rel capture
+ i = i + 1; v = i
+ !$omp atomic capture,acq_rel , hint (1)
+ i = i + 1; v = i
+ !$omp atomic hint(0),acquire capture
+ i = i + 1; v = i
+ !$omp atomic read acquire
+ v = i
+ !$omp atomic acq_rel read
+ v = i
+ !$omp atomic release,write
+ i = v
+ !$omp atomic write,acq_rel
+ i = v
+ !$omp atomic hint(1),update,release
+ f = f + 2.0
+ !$omp atomic update ,acquire
+ i = i + 1
+ !$omp atomic acq_rel update
+ i = i + 1
+ !$omp atomic acq_rel,hint(0)
+ i = i + 1
+end
+end module
new file mode 100644
@@ -0,0 +1,27 @@
+module m
+implicit none
+integer i, v
+real f
+contains
+subroutine foo (j)
+integer, value :: j
+ !$omp atomic update,update ! { dg-error "Duplicated atomic clause: unexpected update clause" }
+ i = i + 1
+ !$omp atomic seq_cst release ! { dg-error "Duplicated memory-order clause: unexpected release clause" }
+ i = i + 1
+ !$omp atomic read,release ! { dg-error "ATOMIC READ at .1. incompatible with RELEASE clause" }
+ v = i
+ !$omp atomic acquire , write ! { dg-error "ATOMIC WRITE at .1. incompatible with ACQUIRE clause" }
+ i = v
+ !$omp atomic capture hint (0) capture ! { dg-error "Duplicated 'capture' clause" }
+ v = i = i + 1
+ !$omp atomic hint(j + 2) ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" }
+ i = i + 1
+ !$omp atomic hint(f)
+ ! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 }
+ ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 }
+ i = i + 1
+ !$omp atomic foobar ! { dg-error "Failed to match clause" }
+ i = i + 1
+end
+end module
new file mode 100644
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic relaxed" 3 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic read relaxed" 1 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic capture relaxed" 1 "original" } }
+
+module mod
+ implicit none
+ integer i, j, k, l, m, n
+
+contains
+
+subroutine foo ()
+ !$omp atomic release
+ i = i + 1;
+end
+end
+
+module m2
+use mod
+implicit none
+!$omp requires atomic_default_mem_order (relaxed)
+
+contains
+subroutine bar ()
+ integer v;
+ !$omp atomic
+ j = j + 1
+ !$omp atomic update
+ k = k + 1
+ !$omp atomic read
+ v = l
+ !$omp atomic write
+ m = v
+ !$omp atomic capture
+ n = n + 1; v = n
+end
+end module m2
@@ -3,13 +3,13 @@
subroutine bar
integer :: i, v
real :: f
- !$omp atomic update acq_rel hint("abc") ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
+ !$omp atomic update acq_rel hint("abc")
! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 }
! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 }
i = i + 1
!$omp end atomic
- !$omp atomic acq_rel ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
+ !$omp atomic acq_rel
i = i + 1
!$omp end atomic
@@ -18,7 +18,7 @@ subroutine bar
v = i
!$omp end atomic
- !$omp atomic acq_rel , hint (1), update ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
+ !$omp atomic acq_rel , hint (1), update
i = i + 1
!$omp end atomic
@@ -27,44 +27,10 @@ subroutine bar
v = i
!$omp end atomic
- !$omp atomic write capture ! { dg-error "multiple atomic clauses" }
+ !$omp atomic write capture ! { dg-error "with CAPTURE clause is incompatible with READ or WRITE" }
i = 2
v = i
!$omp end atomic
!$omp atomic foobar ! { dg-error "Failed to match clause" }
end
-
-! moved here from atomic.f90
-subroutine openmp51_foo
- integer :: x, v
- !$omp atomic update seq_cst capture ! { dg-error "multiple atomic clauses" }
- x = x + 2
- v = x
- !$omp end atomic
- !$omp atomic seq_cst, capture, update ! { dg-error "multiple atomic clauses" }
- x = x + 2
- v = x
- !$omp end atomic
- !$omp atomic capture, seq_cst ,update ! { dg-error "multiple atomic clauses" }
- x = x + 2
- v = x
- !$omp end atomic
-end
-
-subroutine openmp51_bar
- integer :: i, v
- real :: f
- !$omp atomic relaxed capture update ! { dg-error "multiple atomic clauses" }
- i = i + 1
- v = i
- !$omp end atomic
- !$omp atomic update capture,release , hint (1) ! { dg-error "multiple atomic clauses" }
- i = i + 1
- v = i
- !$omp end atomic
- !$omp atomic hint(0),update relaxed capture ! { dg-error "multiple atomic clauses" }
- i = i + 1
- v = i
- !$omp end atomic
-end
new file mode 100644
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic seq_cst" 3 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic read seq_cst" 1 "original" } }
+! { dg-final { scan-tree-dump-times "omp atomic capture seq_cst" 1 "original" } }
+
+module mod
+implicit none
+integer i, j, k, l, m, n
+
+contains
+subroutine foo ()
+ !$omp atomic release
+ i = i + 1
+end
+end module
+
+module m2
+use mod
+implicit none
+!$omp requires atomic_default_mem_order (seq_cst)
+
+contains
+
+subroutine bar ()
+ integer v
+ !$omp atomic
+ j = j + 1
+ !$omp atomic update
+ k = k + 1
+ !$omp atomic read
+ v = l
+ !$omp atomic write
+ m = v
+ !$omp atomic capture
+ n = n + 1; v = n
+end
+end module
new file mode 100644
@@ -0,0 +1,24 @@
+module mod
+integer i, j
+
+contains
+subroutine foo ()
+ integer v
+ !$omp atomic release
+ i = i + 1
+ !$omp atomic read
+ v = j
+end
+end module
+
+module m2
+!$omp requires atomic_default_mem_order (acq_rel) ! OK
+contains
+subroutine bar
+ !$omp atomic release
+ i = i + 1
+!$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "must appear in the specification part of a program unit" }
+ !$omp atomic read
+ v = j
+end subroutine
+end module m2
new file mode 100644
@@ -0,0 +1,13 @@
+! PR c/101297
+
+module m
+implicit none
+integer :: i
+contains
+subroutine foo ()
+ !$omp atomic update, ! { dg-error "Clause expected at .1. after tailing comma" }
+ i = i + 1
+ !$omp atomic update,, ! { dg-error "Failed to match clause" }
+ i = i + 1
+end
+end module
new file mode 100644
@@ -0,0 +1,53 @@
+! { dg-do compile }
+
+module m
+use iso_fortran_env
+implicit none
+integer, parameter :: mrk = maxval(real_kinds)
+integer x, r, z
+real(kind(4.0d0)) d, v
+real(mrk) ld
+
+contains
+subroutine foo (y, e, f)
+ integer :: y
+ real(kind(4.0d0)) :: e
+ real(mrk) :: f
+ !$omp atomic update seq_cst fail(acquire)
+ x = min(x, y)
+ !$omp atomic relaxed fail(relaxed)
+ d = max (e, d)
+ !$omp atomic fail(SEQ_CST)
+ d = min (d, f)
+ !$omp atomic seq_cst compare fail(relaxed) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 7) x = 24
+ !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 7) x = 24
+ !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 123) x = 256
+ !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (ld == f) ld = f + 5.0_mrk
+ !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 9) then
+ x = 5
+ endif
+ !$omp atomic compare update capture seq_cst fail(acquire) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 42) then
+ x = f
+ else
+ v = x
+ endif
+ !$omp atomic capture compare weak ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (x == 42) then
+ x = f
+ else
+ v = x
+ endif
+ !$omp atomic capture compare fail(seq_cst) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ if (d == 8.0) then
+ d = 16.0
+ else
+ v = d
+ end if
+end
+end module
new file mode 100644
@@ -0,0 +1,75 @@
+! { dg-do compile }
+
+module m
+implicit none
+integer x
+real d
+
+contains
+
+real function foo (y, e, f)
+ integer :: y
+ real v, e
+ real(8) :: f
+ !$omp atomic compare compare ! { dg-error "Duplicated 'compare' clause" }
+ if (x == y) x = d
+ !$omp atomic compare fail(seq_cst) fail(seq_cst) ! { dg-error "Duplicated 'fail' clause" }
+ if (x == y) x = d
+ !$omp atomic compare,fail(seq_cst),fail(relaxed) ! { dg-error "Duplicated 'fail' clause" }
+ if (x == y) x = d
+ !$omp atomic compare weak weak ! { dg-error "Duplicated 'weak' clause" }
+ if (x == y) x = d
+ !$omp atomic read capture ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" }
+ v = d
+ !$omp atomic capture, write ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" }
+ d = v; v = v + 1 ! { dg-error "Unexpected ..OMP ATOMIC statement" "" { target *-*-* } .-1 }
+ foo = v
+end
+
+real function bar (y, e, f)
+ integer :: y
+ real v, e
+ real(8) :: f
+ !$omp atomic read compare ! { dg-error "COMPARE clause is incompatible with READ or WRITE" }
+ if (x == y) x = d
+ !$omp atomic compare, write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" }
+ if (x == y) x = d
+ !$omp atomic read fail(seq_cst) ! { dg-error "FAIL clause is incompatible with READ or WRITE" }
+ v = d
+ !$omp atomic fail(relaxed), write ! { dg-error "FAIL clause is incompatible with READ or WRITE" }
+ d = v
+ !$omp atomic fail(relaxed) update ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
+ d = d + 3.0
+ !$omp atomic fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
+ d = d + 3.0
+ !$omp atomic capture fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
+ v = d; d = d + 3.0
+ !$omp atomic read weak ! { dg-error "WEAK clause requires COMPARE clause" }
+ v = d
+ !$omp atomic weak, write ! { dg-error "WEAK clause requires COMPARE clause" }
+ d = v
+ !$omp atomic weak update ! { dg-error "WEAK clause requires COMPARE clause" }
+ d = d + 3.0
+ !$omp atomic weak ! { dg-error "WEAK clause requires COMPARE clause" }
+ d = d + 3.0
+ !$omp atomic capture weak ! { dg-error "WEAK clause requires COMPARE clause" }
+ d = d + 3.0; v = d
+ !$omp atomic capture
+ d = d + 3.0; v = x ! { dg-error "capture statement reads from different variable than update statement writes" }
+ !$omp atomic compare fail ! { dg-error "Expected '\\\(' after 'fail'" }
+ if (x == y) x = d
+ !$omp atomic compare fail( ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
+ if (x == y) x = d ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" "" { target *-*-* } .-1 }
+ !$omp atomic compare fail() ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
+ if (x == y) x = d
+ !$omp atomic compare fail(foobar) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
+ if (x == y) x = d
+ !$omp atomic compare fail(acq_rel) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
+ if (x == y) x = d
+ !$omp atomic compare fail(release) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
+ if (x == y) x = d
+ !$omp atomic compare fail(seq_cst ! { dg-error "Failed to match clause" }
+ if (x == y) x = d
+ bar = v
+end
+end module
@@ -3,14 +3,13 @@
! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 4 "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 4 "original" } }
-! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 2 "original" } }
-! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 1 "original" } }
+! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 4 "original" } }
+! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 2 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst" 7 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read seq_cst" 3 "original" } }
-! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 3 "original" } }
-
+! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 6 "original" } }
subroutine foo ()
integer :: x, v
@@ -85,3 +84,36 @@ subroutine bar
!$omp atomic hint(1),update,release
f = f + 2.0
end
+
+subroutine openmp51_foo
+ integer :: x, v
+ !$omp atomic update seq_cst capture
+ x = x + 2
+ v = x
+ !$omp end atomic
+ !$omp atomic seq_cst, capture, update
+ x = x + 2
+ v = x
+ !$omp end atomic
+ !$omp atomic capture, seq_cst ,update
+ x = x + 2
+ v = x
+ !$omp end atomic
+end
+
+subroutine openmp51_bar
+ integer :: i, v
+ real :: f
+ !$omp atomic relaxed capture update
+ i = i + 1
+ v = i
+ !$omp end atomic
+ !$omp atomic update capture,release , hint (1)
+ i = i + 1
+ v = i
+ !$omp end atomic
+ !$omp atomic hint(0),update relaxed capture
+ i = i + 1
+ v = i
+ !$omp end atomic
+end
new file mode 100644
@@ -301,7 +301,8 @@ The OpenMP 4.5 specification is fully supported.
@item @code{interop} directive @tab N @tab
@item @code{omp_interop_t} object support in runtime routines @tab N @tab
@item @code{nowait} clause in @code{taskwait} directive @tab N @tab
-@item Extensions to the @code{atomic} directive @tab P @tab C/C++ only
+@item Extensions to the @code{atomic} directive @tab P
+ @tab @code{compare} unsupported in Fortran
@item @code{seq_cst} clause on a @code{flush} construct @tab Y @tab
@item @code{inoutset} argument to the @code{depend} clause @tab N @tab
@item @code{private} and @code{firstprivate} argument to @code{default}