Fortran/OpenMP: Fix handling of strictly structured blocks

For strictly structured blocks, a BLOCK was created but the code
was placed after the block the outer structured block. Additionally,
labelled blocks were mishandled. As the code is now properly in a
BLOCK, it solves additional issues.

gcc/fortran/ChangeLog:

	* parse.cc (parse_omp_structured_block): Make the user code end
	up inside of BLOCK construct for strictly structured blocks;
	fix fallout for 'section' and 'teams'.
	* openmp.cc (resolve_omp_target): Fix changed BLOCK handling
	for teams in target checking.

libgomp/ChangeLog:

	* testsuite/libgomp.fortran/strictly-structured-block-1.f90: New test.

gcc/testsuite/ChangeLog:

	* gfortran.dg/block_17.f90: New test.
	* gfortran.dg/gomp/strictly-structured-block-5.f90: New test.

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index dc0c8013c3d03bd5c57a5346458e30f9db6cd30b..79b5ae0e4bd8693ff945d95d72241d331d688f97 100644 (file)
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -11245,6 +11245,8 @@ resolve_omp_target (gfc_code *code)
   if (!code->ext.omp_clauses->contains_teams_construct)
     return;
   gfc_code *c = code->block->next;
+  if (c->op == EXEC_BLOCK)
+    c = c->ext.block.ns->code;
   if (code->ext.omp_clauses->target_first_st_is_teams
       && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
          || (c->op == EXEC_BLOCK

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 58386805ffe0f66093b86a3f44562e6d82c191ae..444baf42cbdd39d2abb7f35a99e1d2672c197f3d 100644 (file)
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5814,7 +5814,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
 {
   gfc_statement st, omp_end_st, first_st;
   gfc_code *cp, *np;
-  gfc_state_data s;
+  gfc_state_data s, s2;
 
   accept_statement (omp_st);
 
@@ -5915,13 +5915,21 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
       gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
 
       my_ns = gfc_build_block_ns (gfc_current_ns);
-      gfc_current_ns = my_ns;
-      my_parent = my_ns->parent;
-
       new_st.op = EXEC_BLOCK;
       new_st.ext.block.ns = my_ns;
       new_st.ext.block.assoc = NULL;
       accept_statement (ST_BLOCK);
+
+      push_state (&s2, COMP_BLOCK, my_ns->proc_name);
+      gfc_current_ns = my_ns;
+      my_parent = my_ns->parent;
+      if (omp_st == ST_OMP_SECTIONS
+         || omp_st == ST_OMP_PARALLEL_SECTIONS)
+       {
+         np = new_level (cp);
+         np->op = cp->op;
+       }
+
       first_st = next_statement ();
       st = parse_spec (first_st);
     }
@@ -5937,6 +5945,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
       case ST_OMP_TEAMS_LOOP:
        {
          gfc_state_data *stk = gfc_state_stack->previous;
+         if (stk->state == COMP_OMP_STRICTLY_STRUCTURED_BLOCK)
+           stk = stk->previous;
          stk->tail->ext.omp_clauses->target_first_st_is_teams = true;
          break;
        }
@@ -6035,8 +6045,10 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
       else if (block_construct && st == ST_END_BLOCK)
        {
          accept_statement (st);
+         gfc_current_ns->code = gfc_state_stack->head;
          gfc_current_ns = my_parent;
-         pop_state ();
+         pop_state ();  /* Inner BLOCK */
+         pop_state ();  /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
 
          st = next_statement ();
          if (st == omp_end_st)

diff --git a/gcc/testsuite/gfortran.dg/block_17.f90 b/gcc/testsuite/gfortran.dg/block_17.f90
new file mode 100644 (file)
index 0000000..6ab3106
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/block_17.f90
@@ -0,0 +1,9 @@
+subroutine foo()
+  block
+  end block
+end
+
+subroutine bar()
+  my_name: block
+  end block my_name
+end

diff --git a/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90 b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90
new file mode 100644 (file)
index 0000000..79cb920
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/strictly-structured-block-5.f90
@@ -0,0 +1,77 @@
+subroutine f()
+  !$omp parallel
+  block
+  end block
+
+  !$omp parallel
+  block
+    inner: block
+       block
+       end block
+    end block inner
+  end block
+end
+
+subroutine f2()
+  !$omp parallel
+  my_name : block
+  end block my_name
+
+  !$omp parallel
+  another_block : block
+    inner: block
+       block
+       end block
+    end block inner
+  end block another_block
+end
+
+subroutine f3()
+  !$omp parallel
+  my_name : block
+  end block my_name2  ! { dg-error "Expected label 'my_name' for END BLOCK statement" }
+  end block my_name   ! avoid follow up errors
+end subroutine
+
+subroutine f4
+  integer :: n
+  n = 5
+  !$omp parallel
+  my: block
+    integer :: A(n)
+    A(1) = 1
+  end block my
+end
+
+subroutine f4a
+  intrinsic :: sin
+  !$omp parallel
+  block
+    procedure(), pointer :: proc
+    procedure(sin) :: my_sin
+    proc => sin
+  end block
+end subroutine
+
+subroutine f5(x)
+  !$omp parallel
+  block
+    intent(in) :: x  ! { dg-error "INTENT is not allowed inside of BLOCK" }
+    optional :: x    ! { dg-error "OPTIONAL is not allowed inside of BLOCK" }
+    value :: x       ! { dg-error "VALUE is not allowed inside of BLOCK" }
+  end block
+end
+
+subroutine f6()
+  !$omp parallel
+  myblock: block
+    cycle myblock !  { dg-error "CYCLE statement at .1. is not applicable to non-loop construct 'myblock'" }
+  end block myblock
+
+  !$omp parallel
+  myblock2: block
+    exit  myblock2 ! OK.
+    ! jumps to the end of the block but stays in the structured block
+  end block myblock2
+  !$omp end parallel
+end

diff --git a/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90 b/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90
new file mode 100644 (file)
index 0000000..8e7f6c8
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/strictly-structured-block-1.f90
@@ -0,0 +1,22 @@
+subroutine one
+  implicit none (external, type)
+  integer :: i, j
+  i = 5
+  j = 6
+  !$omp parallel
+  my_block : block
+    !$omp atomic write
+    i = 7
+    exit my_block
+
+    !$omp atomic write
+    j = 99  ! Should be unreachable
+
+    ! exit should jump here - end of block but inside of it.
+  end block my_block
+  if (i /= 7) stop 1
+  if (j /= 6) stop 2
+end
+
+ call one
+end