On 2/4/25 01:49, Tobias Burnus wrote:
[snip]
To conclude: The patch LGTM but consider giving the user some hint
how to solve it, e.g. using one of the ideas above.
Thanks for the review. I've pushed the attached version of the patch,
which suggests using BLOCK or BEGIN/END METADIRECTIVE (but the latter
only if the error was not already diagnosed in BEGIN/END METADIRECTIVE).
-Sandra
From 5753f459444fa61a93d23325cd59467dc1838eef Mon Sep 17 00:00:00 2001
From: Sandra Loosemore <sloosem...@baylibre.com>
Date: Sat, 8 Feb 2025 17:44:55 +0000
Subject: [PATCH] [PATCH] OpenMP: Improve Fortran metadirective diagnostics
[PR107067]
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 | 62 ++++++++++++++---
.../gfortran.dg/gomp/metadirective-11.f90 | 67 +++++++++++++++++--
2 files changed, 114 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5094d9d3ead..336ea89c5a9 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)
@@ -6409,10 +6428,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)
{
@@ -6470,8 +6491,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)
@@ -6483,15 +6520,22 @@ 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)
+ {
+ if (omp_st == ST_OMP_METADIRECTIVE)
+ gfc_error_now ("Variants in a metadirective at %L have "
+ "different associations; "
+ "consider using a BLOCK construct "
+ "or BEGIN/END METADIRECTIVE", &body_locus);
+ else
+ gfc_error_now ("Variants in a metadirective at %L have "
+ "different associations; "
+ "consider using a BLOCK construct", &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
