[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.

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5094d9d3eadf6b0e120966df41a0baae213dc575..336ea89c5a9f20aa2c1eb29f49b575786f22c631 100644 (file)
--- 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 e7de70e62598194b1a19f847634ae15ea4b639cf..15aba210ce8fb0a63685fb5fd32420b99e0b12ac 100644 (file)
--- 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