OpenMP: Fix ICE with OMP metadirectives

Problem: ending an OpenMP metadirective block with an OMP end statement
results in an internal compiler error.
Solution: reject invalid end statements and issue a proper diagnostic.

This revision also fixes a couple of minor metadirective issues and adds
related test cases.

gcc/fortran/ChangeLog:

	* parse.cc (gfc_ascii_statement): Missing $ in !$OMP END METADIRECTIVE.
	(parse_omp_structured_block): Fix handling of OMP end metadirective.
	(parse_omp_metadirective_body): Reject OMP end statements
	at the end of an OMP metadirective.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/metadirective-1.f90: Match !$OMP END METADIRECTIVE.
	* gfortran.dg/gomp/metadirective-10.f90: New test.
	* gfortran.dg/gomp/metadirective-11.f90: New xfail test.
	* gfortran.dg/gomp/metadirective-9.f90: New test.

diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 923a46312a96b90b4a2f3dadab6be08e9ce86002..7e782d5820ffd633f7fe9e6ebe70b65041057b85 100644 (file)
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,11 @@
+
+2022-09-28  Paul-Antoine Arras  <pa@codesourcery.com>
+
+       * parse.cc (gfc_ascii_statement): Missing $ in !$OMP END METADIRECTIVE.
+       (parse_omp_structured_block): Fix handling of OMP end metadirective.
+       (parse_omp_metadirective_body): Reject OMP end statements
+       at the end of an OMP metadirective.
+
 2022-09-23  Tobias Burnus  <tobias@codesourcery.com>
 
        Backport from mainline:

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index b35d76a4f6b98edf31b58945e0d11d51d7f058e8..fc88111a7adfb4ee5323ba2d1bcdeb25056f0bf1 100644 (file)
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -2517,7 +2517,7 @@ gfc_ascii_statement (gfc_statement st)
       p = "!$OMP END MASTER TASKLOOP SIMD";
       break;
     case ST_OMP_END_METADIRECTIVE:
-      p = "!OMP END METADIRECTIVE";
+      p = "!$OMP END METADIRECTIVE";
       break;
     case ST_OMP_END_ORDERED:
       p = "!$OMP END ORDERED";
@@ -5643,9 +5643,15 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
   np->block = NULL;
 
   omp_end_st = gfc_omp_end_stmt (omp_st, false, true);
-  if (omp_st == ST_NONE)
+  if (omp_end_st == ST_NONE)
     gcc_unreachable ();
 
+  /* If handling a metadirective variant, treat 'omp end metadirective'
+     as the expected end statement for the current construct.  */
+  if (gfc_state_stack->previous != NULL
+      && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE)
+    omp_end_st = ST_OMP_END_METADIRECTIVE;
+
   bool block_construct = false;
   gfc_namespace *my_ns = NULL;
   gfc_namespace *my_parent = NULL;
@@ -5744,13 +5750,6 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
       else
        st = parse_executable (st);
 
-      /* 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->previous != NULL
-         && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE)
-       st = omp_end_st;
-
       if (st == ST_NONE)
        unexpected_eof ();
       else if (st == ST_OMP_SECTION
@@ -5863,6 +5862,21 @@ parse_omp_metadirective_body (gfc_statement omp_st)
          break;
        }
 
+      if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE
+         && startswith (gfc_ascii_statement (st), "!$OMP END "))
+       {
+         for (gfc_state_data *p = gfc_state_stack; p; p = p->previous)
+           if (p->state == COMP_OMP_STRUCTURED_BLOCK
+               || p->state == COMP_OMP_BEGIN_METADIRECTIVE)
+             goto finish;
+         gfc_error (
+           "Unexpected %s statement in an OMP METADIRECTIVE block at %C",
+           gfc_ascii_statement (st));
+         reject_statement ();
+         st = next_statement ();
+       }
+    finish:
+
       gfc_in_metadirective_body = old_in_metadirective_body;
 
       if (gfc_state_stack->head)

diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 15e95baa08920dfb7a6f0e46dfd7db2988cea66a..435914c8bdb22d4e01e7c0a0a2c2cab5b4763aeb 100644 (file)
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,10 @@
+2022-09-28  Paul-Antoine Arras  <pa@codesourcery.com>
+
+       * gfortran.dg/gomp/metadirective-1.f90: Match !$OMP END METADIRECTIVE.
+       * gfortran.dg/gomp/metadirective-10.f90: New test.
+       * gfortran.dg/gomp/metadirective-11.f90: New test.
+       * gfortran.dg/gomp/metadirective-9.f90: New test.
+
 2022-09-27  Tobias Burnus  <tobias@codesourcery.com>
 
        Backport from mainline:

diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90
index aa439fc855edfb44b4fae62700c89843fc87e906..ca62aecad899155a8143dadff891d36e70a578a4 100644 (file)
--- a/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-1.f90
@@ -37,5 +37,5 @@ program main
     do i = 1, N
       c(i) = a(i) * b(i)
     end do
-  !$omp end metadirective ! { dg-error "Unexpected !OMP END METADIRECTIVE statement at .1." }
+  !$omp end metadirective ! { dg-error "Unexpected !.OMP END METADIRECTIVE statement at .1." }
 end program

diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-10.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-10.f90
new file mode 100644 (file)
index 0000000..5dad5d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-10.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+
+program metadirectives
+   implicit none
+   logical :: UseDevice
+
+   !$OMP metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : parallel ) &
+   !$OMP   default ( parallel )
+   block
+      call bar()
+   end block
+
+   !$OMP metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : parallel ) &
+   !$OMP   default ( parallel )
+   call bar()
+   !$omp end parallel  ! Accepted, because all cases have 'parallel'
+   
+   !$OMP begin metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : nothing ) &
+   !$OMP   default ( parallel )
+   call bar()
+   block
+      call foo()
+   end block
+   !$OMP end metadirective
+
+   !$OMP begin metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : parallel ) &
+   !$OMP   default ( parallel )
+   call bar()
+   !$omp end parallel  ! { dg-error "Unexpected !.OMP END PARALLEL statement at .1." }
+end program ! { dg-error "Unexpected END statement at .1." }
+
+! { dg-error "Unexpected end of file" "" { target *-*-* } 0 }

diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
new file mode 100644 (file)
index 0000000..e7de70e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-11.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-ice "Statements following a block in a metadirective" }
+! PR fortran/107067
+
+program metadirectives
+   implicit none
+   logical :: UseDevice
+
+   !$OMP begin metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : nothing ) &
+   !$OMP   default ( parallel )
+   block
+      call foo()
+   end block
+   call bar()   ! FIXME/XFAIL ICE in parse_omp_metadirective_body()
+   !$omp end metadirective
+
+
+   !$OMP begin metadirective &
+   !$OMP   when ( user = { condition ( UseDevice ) } &
+   !$OMP     : nothing ) &
+   !$OMP   default ( parallel )
+   block
+      call bar()
+   end block
+   block        ! FIXME/XFAIL ICE in parse_omp_metadirective_body()
+      call foo()
+   end block
+   !$omp end metadirective
+end program
+
+

diff --git a/gcc/testsuite/gfortran.dg/gomp/metadirective-9.f90 b/gcc/testsuite/gfortran.dg/gomp/metadirective-9.f90
new file mode 100644 (file)
index 0000000..e6ab3fc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/metadirective-9.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+
+program OpenMP_Metadirective_WrongEnd_Test
+  implicit none
+
+  integer :: &
+  iaVS, iV, jV, kV
+  integer, dimension ( 3 ) :: &
+    lV, uV
+  logical :: &
+    UseDevice
+
+    !$OMP metadirective &
+    !$OMP   when ( user = { condition ( UseDevice ) } &
+    !$OMP     : target teams distribute parallel do simd collapse ( 3 ) &
+    !$OMP         private ( iaVS ) ) &
+    !$OMP   default ( parallel do simd collapse ( 3 ) private ( iaVS ) )
+    do kV = lV ( 3 ), uV ( 3 )
+      do jV = lV ( 2 ), uV ( 2 )
+        do iV = lV ( 1 ), uV ( 1 )
+
+
+        end do
+      end do
+    end do
+    !$OMP end target teams distribute parallel do simd ! { dg-error "Unexpected !.OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD statement in an OMP METADIRECTIVE block at .1." }
+
+
+end program
+