The Fortran front end was giving an ICE instead of a user-friendly
diagnostic when variants of a metadirective variant had different
statement associations. The particular test case reported in the issue
also involved invalid placement of the "omp end metadirective" which
was not being diagnosed either.
gcc/fortran/ChangeLog
PR middle-end/107067
* parse.cc (parse_omp_do): Diagnose missing "OMP END METADIRECTIVE"
after loop.
(parse_omp_structured_block): Likewise for strictly structured block.
(parse_omp_metadirective_body): Use better test for variants ending
at different places. Issue a user diagnostic at the end if any
were inconsistent, instead of calling gcc_assert.
gcc/testsuite/ChangeLog
PR middle-end/107067
* gfortran.dg/gomp/metadirective-11.f90: Remove the dg-ice, update
for current behavior, and add more tests to exercise the new error
code.
---
gcc/fortran/parse.cc | 53 ++++++++++++---
.../gfortran.dg/gomp/metadirective-11.f90 | 67 +++++++++++++++++--
2 files changed, 105 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 00cd23d7729..933cfe8c58f 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5804,9 +5804,20 @@ do_end:
/* If handling a metadirective variant, treat 'omp end metadirective'
as the expected end statement for the current construct. */
- if (st == ST_OMP_END_METADIRECTIVE
- && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
- st = omp_end_st;
+ if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
+ {
+ if (st == ST_OMP_END_METADIRECTIVE)
+ st = omp_end_st;
+ else
+ {
+ /* We have found some extra statements between the loop
+ and the "end metadirective" which is required in a
+ "begin metadirective" construct, or perhaps the
+ "end metadirective" is missing entirely. */
+ gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
+ return st;
+ }
+ }
if (st == omp_end_st)
{
@@ -6294,6 +6305,14 @@ parse_omp_structured_block (gfc_statement omp_st, bool
workshare_stmts_only)
accept_statement (st);
st = next_statement ();
}
+ else if (omp_end_st == ST_OMP_END_METADIRECTIVE)
+ {
+ /* We have found some extra statements between the END BLOCK
+ and the "end metadirective" which is required in a
+ "begin metadirective" construct, or perhaps the
+ "end metadirective" is missing entirely. */
+ gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
+ }
return st;
}
else if (st != omp_end_st || block_construct)
@@ -6406,10 +6425,12 @@ parse_omp_metadirective_body (gfc_statement omp_st)
gfc_omp_variant *variant
= new_st.ext.omp_variants;
locus body_locus = gfc_current_locus;
+ bool saw_error = false;
accept_statement (omp_st);
gfc_statement next_st = ST_NONE;
+ locus next_loc;
while (variant)
{
@@ -6467,8 +6488,24 @@ parse_omp_metadirective_body (gfc_statement omp_st)
reject_statement ();
st = next_statement ();
}
+
finish:
+ /* Sanity-check that each variant finishes parsing at the same place. */
+ if (next_st == ST_NONE)
+ {
+ next_st = st;
+ next_loc = gfc_current_locus;
+ }
+ else if (st != next_st
+ || next_loc.nextc != gfc_current_locus.nextc
+ || next_loc.u.lb != gfc_current_locus.u.lb)
+ {
+ saw_error = true;
+ next_st = st;
+ next_loc = gfc_current_locus;
+ }
+
gfc_in_omp_metadirective_body = old_in_metadirective_body;
if (gfc_state_stack->head)
@@ -6480,15 +6517,13 @@ parse_omp_metadirective_body (gfc_statement omp_st)
if (variant->next)
gfc_clear_new_st ();
- /* Sanity-check that each variant finishes parsing at the same place. */
- if (next_st == ST_NONE)
- next_st = st;
- else
- gcc_assert (st == next_st);
-
variant = variant->next;
}
+ if (saw_error)
+ gfc_error_now ("Variants in a metadirective at %L have "
+ "different associations", &body_locus);
+
return next_st;
}
diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
b/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
index e7de70e6259..15aba210ce8 100644
--- a/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
@@ -1,33 +1,88 @@
! { dg-do compile }
-! { dg-ice "Statements following a block in a metadirective" }
! PR fortran/107067
program metadirectives
implicit none
logical :: UseDevice
+ integer :: n, v
!$OMP begin metadirective &
!$OMP when ( user = { condition ( UseDevice ) } &
!$OMP : nothing ) &
- !$OMP default ( parallel )
+ !$OMP default ( parallel ) ! { dg-error "Variants in a metadirective at
.1. have different associations" }
block
call foo()
end block
- call bar() ! FIXME/XFAIL ICE in parse_omp_metadirective_body()
- !$omp end metadirective
+ call bar() ! { dg-error "Expected OMP END METADIRECTIVE" }
+ !$omp end metadirective ! { dg-error "Unexpected ..OMP END METADIRECTIVE
statement" }
+ ! It's a quirk of the implementation that gfortran thinks the metadirective
+ ! ends where the *last* variant ends. If we reverse the order of the
+ ! variants from the previous case, the "unexpected OMP END METADIRECTIVE"
+ ! error disappears because the "nothing" variant eats it where the
+ ! "parallel" directive doesn't.
+
+ !$OMP begin metadirective &
+ !$OMP when ( user = { condition ( UseDevice ) } &
+ !$OMP : parallel ) &
+ !$OMP default ( nothing ) ! { dg-error "Variants in a metadirective at
.1. have different associations" }
+ block
+ call foo()
+ end block
+ call bar() ! { dg-error "Expected OMP END METADIRECTIVE" }
+ !$omp end metadirective
!$OMP begin metadirective &
!$OMP when ( user = { condition ( UseDevice ) } &
!$OMP : nothing ) &
- !$OMP default ( parallel )
+ !$OMP default ( parallel ) ! { dg-error "Variants in a metadirective at
.1. have different associations" }
block
call bar()
end block
- block ! FIXME/XFAIL ICE in parse_omp_metadirective_body()
+ block ! { dg-error "Expected OMP END METADIRECTIVE" }
call foo()
end block
+ !$omp end metadirective ! { dg-error "Unexpected ..OMP END METADIRECTIVE
statement" }
+
+ ! This one depends on the locus comparison and not just the statement
+ ! code comparison to diagnose the "different associations" error, since
+ ! there are two call statements involved.
+ !$OMP begin metadirective &
+ !$OMP when ( user = { condition ( UseDevice ) } &
+ !$OMP : nothing ) &
+ !$OMP default ( parallel ) ! { dg-error "Variants in a metadirective at
.1. have different associations" }
+ block
+ call foo()
+ end block
+ call bar() ! { dg-error "Expected OMP END METADIRECTIVE" }
+ !$omp end metadirective ! { dg-error "Unexpected ..OMP END METADIRECTIVE
statement" }
+ call baz()
+
+ ! The "nothing" directive in a non-begin/end metadirective only applies to a
+ ! a single statement or block, while "atomic capture" permits multiple
+ ! assignment statements.
+ !$OMP metadirective &
+ !$OMP when ( user = { condition ( UseDevice ) } &
+ !$OMP : nothing ) &
+ !$OMP default (atomic capture) ! { dg-error "Variants in a metadirective
at .1. have different associations" }
+ n = n + 1; v = n
+
+ ! Reverse order of the above.
+ !$OMP metadirective &
+ !$OMP when ( user = { condition ( UseDevice ) } &
+ !$OMP : atomic capture ) &
+ !$OMP default ( nothing ) ! { dg-error "Variants in a metadirective at
.1. have different associations" }
+ n = n + 1; v = n
+
+ ! This one is correct because both variants are properly terminated
+ ! by the "end metadirective".
+ !$OMP begin metadirective &
+ !$OMP when ( user = { condition ( UseDevice ) } &
+ !$OMP : nothing ) &
+ !$OMP default (atomic capture)
+ n = n + 1; v = n
!$omp end metadirective
+
end program
--
2.34.1
