Hi!
The resolve_omp_atomic code relied on gfc_resolve_blocks not actually
changing the kinds and number of statements, which is apparently no longer
the case, there are various changes where those can change, e.g. after
diagnosing an error EXEC_ASSIGN can be changed into EXEC_NOP, or for the F08
fn(arg) = val
where fn returns pointer. I've committed following patch after
bootstrapping/regtesting it on x86_64-linux and i686-linux, which moves the
assertions earlier (before gfc_resolve_blocks is done in the nested stmts)
and tweak resolve_omp_atomic so that instead of assertions it either returns
early or diagnoses an error.
2016-08-31 Jakub Jelinek <ja...@redhat.com>
PR fortran/77374
* parse.c (parse_omp_oacc_atomic): Copy over cp->ext.omp_atomic
to cp->block->ext.omp_atomic.
* resolve.c (gfc_resolve_blocks): Assert block with one or two
EXEC_ASSIGNs for EXEC_*_ATOMIC.
* openmp.c (resolve_omp_atomic): Don't assert one or two
EXEC_ASSIGNs, instead return quietly for EXEC_NOPs and otherwise
error unexpected statements.
* gfortran.dg/gomp/pr77374.f08: New test.
--- gcc/fortran/parse.c.jj 2016-08-29 12:17:09.000000000 +0200
+++ gcc/fortran/parse.c 2016-08-30 16:57:16.982107686 +0200
@@ -4695,6 +4695,7 @@ parse_omp_oacc_atomic (bool omp_p)
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
+ np->ext.omp_atomic = cp->ext.omp_atomic;
count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
== GFC_OMP_ATOMIC_CAPTURE);
--- gcc/fortran/resolve.c.jj 2016-08-29 12:17:09.000000000 +0200
+++ gcc/fortran/resolve.c 2016-08-30 17:18:09.607225924 +0200
@@ -9464,6 +9464,24 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
case EXEC_WAIT:
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OACC_ATOMIC:
+ {
+ gfc_omp_atomic_op aop
+ = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
+
+ /* Verify this before calling gfc_resolve_code, which might
+ change it. */
+ gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
+ gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE)
+ && b->next->next == NULL)
+ || ((aop == GFC_OMP_ATOMIC_CAPTURE)
+ && b->next->next != NULL
+ && b->next->next->op == EXEC_ASSIGN
+ && b->next->next->next == NULL));
+ }
+ break;
+
case EXEC_OACC_PARALLEL_LOOP:
case EXEC_OACC_PARALLEL:
case EXEC_OACC_KERNELS_LOOP:
@@ -9476,9 +9494,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
- case EXEC_OACC_ATOMIC:
case EXEC_OACC_ROUTINE:
- case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
--- gcc/fortran/openmp.c.jj 2016-08-15 10:13:26.000000000 +0200
+++ gcc/fortran/openmp.c 2016-08-30 17:40:57.241654954 +0200
@@ -3946,12 +3946,33 @@ resolve_omp_atomic (gfc_code *code)
= (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
code = code->block->next;
- gcc_assert (code->op == EXEC_ASSIGN);
- gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
- || ((aop == GFC_OMP_ATOMIC_CAPTURE)
- && code->next != NULL
- && code->next->op == EXEC_ASSIGN
- && code->next->next == NULL));
+ /* resolve_blocks asserts this is initially EXEC_ASSIGN.
+ If it changed to EXEC_NOP, assume an error has been emitted already. */
+ if (code->op == EXEC_NOP)
+ return;
+ if (code->op != EXEC_ASSIGN)
+ {
+ unexpected:
+ gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
+ return;
+ }
+ if (aop != GFC_OMP_ATOMIC_CAPTURE)
+ {
+ if (code->next != NULL)
+ goto unexpected;
+ }
+ else
+ {
+ if (code->next == NULL)
+ goto unexpected;
+ if (code->next->op == EXEC_NOP)
+ return;
+ if (code->next->op != EXEC_ASSIGN || code->next->next)
+ {
+ code = code->next;
+ goto unexpected;
+ }
+ }
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
--- gcc/testsuite/gfortran.dg/gomp/pr77374.f08.jj 2016-08-30
17:42:25.168591066 +0200
+++ gcc/testsuite/gfortran.dg/gomp/pr77374.f08 2016-08-30 17:54:12.961042180
+0200
@@ -0,0 +1,21 @@
+! PR fortran/77374
+! { dg-do compile }
+
+subroutine foo (a, b)
+ integer :: a, b
+!$omp atomic
+ b = b + a
+!$omp atomic
+ z(1) = z(1) + 1 ! { dg-error "must have the pointer attribute" }
+end subroutine
+subroutine bar (a, b)
+ integer :: a, b
+ interface
+ function baz (i) result (res)
+ integer, pointer :: res
+ integer :: i
+ end function
+ end interface
+!$omp atomic
+ baz (i) = 1 ! { dg-error "unexpected" }
+end subroutine
Jakub
