[PR fortran/63858] Fix mix of OpenACC and OpenMP sentinels in continuations

[Thomas Schwinge <thomas at codesourcery dot com>]

Hi!

On Mon, 27 Jul 2015 16:14:17 +0200, I wrote:
> On Tue, 30 Jun 2015 03:39:42 +0300, Ilmir Usmanov <me@ilmir.us> wrote:
> > 08.06.2015, 17:59, "Cesar Philippidis" <cesar@codesourcery.com>:
> > > On 06/07/2015 02:05 PM, Ilmir Usmanov wrote:
> > >>  08.06.2015, 00:01, "Ilmir Usmanov" <me@ilmir.us>:
> > >>>>  This patch fixes checks of OpenMP and OpenACC continuations in
> > >>>>  case if someone mixes them (i.e. continues OpenMP directive with
> > >>>>  !$ACC sentinel or vice versa).
> 
> Thanks for working on this!
> 
> > >>>>  OK for gomp branch?
> 
> The same applies to GCC trunk, as far as I can tell -- any reason not to
> apply the patch to trunk?

Ping -- OK to commit the following (by Ilmir) to trunk:

commit 38e62678ef11f349f029d42439668071f170e059
Author: Ilmir Usmanov <me@ilmir.us>
Date:   Sun Jul 26 12:10:36 2015 +0000

    [PR fortran/63858] Fix mix of OpenACC and OpenMP sentinels in continuations
    
    	gcc/fortran/
    	PR fortran/63858
    	* scanner.c (skip_omp_attribute_fixed, skip_oacc_attribute_fixed):
    	New functions.
    	(skip_fixed_comments, gfc_next_char_literal): Fix mix of OpenACC
    	and OpenMP sentinels in continuation.
    	gcc/testsuite/
    	PR fortran/63858
    	* gfortran.dg/goacc/omp-fixed.f: New file.
    	* gfortran.dg/goacc/omp.f95: Extend.
---
 gcc/fortran/scanner.c                       | 258 +++++++++++++++++-----------
 gcc/testsuite/gfortran.dg/goacc/omp-fixed.f |  32 ++++
 gcc/testsuite/gfortran.dg/goacc/omp.f95     |  10 +-
 3 files changed, 199 insertions(+), 101 deletions(-)

diff --git gcc/fortran/scanner.c gcc/fortran/scanner.c
index bfb7d45..1e1ea84 100644
--- gcc/fortran/scanner.c
+++ gcc/fortran/scanner.c
@@ -935,6 +935,63 @@ skip_free_comments (void)
   return false;
 }
 
+/* Return true if MP was matched in fixed form.  */
+static bool
+skip_omp_attribute_fixed (locus *start)
+{
+  gfc_char_t c;
+  if (((c = next_char ()) == 'm' || c == 'M')
+      && ((c = next_char ()) == 'p' || c == 'P'))
+    {
+      c = next_char ();
+      if (c != '\n'
+	  && (continue_flag
+	      || c == ' ' || c == '\t' || c == '0'))
+	{
+	  do
+	    c = next_char ();
+	  while (gfc_is_whitespace (c));
+	  if (c != '\n' && c != '!')
+	    {
+	      /* Canonicalize to *$omp.  */
+	      *start->nextc = '*';
+	      openmp_flag = 1;
+	      gfc_current_locus = *start;
+	      return true;
+	    }
+	}
+    }
+  return false;
+}
+
+/* Return true if CC was matched in fixed form.  */
+static bool
+skip_oacc_attribute_fixed (locus *start)
+{
+  gfc_char_t c;
+  if (((c = next_char ()) == 'c' || c == 'C')
+      && ((c = next_char ()) == 'c' || c == 'C'))
+    {
+      c = next_char ();
+      if (c != '\n'
+	  && (continue_flag
+	      || c == ' ' || c == '\t' || c == '0'))
+	{
+	  do
+	    c = next_char ();
+	  while (gfc_is_whitespace (c));
+	  if (c != '\n' && c != '!')
+	    {
+	      /* Canonicalize to *$omp.  */
+	      *start->nextc = '*';
+	      openacc_flag = 1;
+	      gfc_current_locus = *start;
+	      return true;
+	    }
+	}
+    }
+  return false;
+}
 
 /* Skip comment lines in fixed source mode.  We have the same rules as
    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
@@ -1003,128 +1060,92 @@ skip_fixed_comments (void)
 	      && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
 	    continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
 
-	  if (flag_openmp || flag_openmp_simd)
+	  if ((flag_openmp || flag_openmp_simd) && !flag_openacc)
 	    {
 	      if (next_char () == '$')
 		{
 		  c = next_char ();
 		  if (c == 'o' || c == 'O')
 		    {
-		      if (((c = next_char ()) == 'm' || c == 'M')
-			  && ((c = next_char ()) == 'p' || c == 'P'))
-			{
-			  c = next_char ();
-			  if (c != '\n'
-			      && ((openmp_flag && continue_flag)
-				  || c == ' ' || c == '\t' || c == '0'))
-			    {
-			      do
-				c = next_char ();
-			      while (gfc_is_whitespace (c));
-			      if (c != '\n' && c != '!')
-				{
-				  /* Canonicalize to *$omp.  */
-				  *start.nextc = '*';
-				  openmp_flag = 1;
-				  gfc_current_locus = start;
-				  return;
-				}
-			    }
-			}
+		      if (skip_omp_attribute_fixed (&start))
+			return;
 		    }
 		  else
-		    {
-		      int digit_seen = 0;
-
-		      for (col = 3; col < 6; col++, c = next_char ())
-			if (c == ' ')
-			  continue;
-			else if (c == '\t')
-			  {
-			    col = 6;
-			    break;
-			  }
-			else if (c < '0' || c > '9')
-			  break;
-			else
-			  digit_seen = 1;
+		    goto check_for_digits;
+		}
+	      gfc_current_locus = start;
+	    }
 
-		      if (col == 6 && c != '\n'
-			  && ((continue_flag && !digit_seen)
-			      || c == ' ' || c == '\t' || c == '0'))
-			{
-			  gfc_current_locus = start;
-			  start.nextc[0] = ' ';
-			  start.nextc[1] = ' ';
-			  continue;
-			}
+	  if (flag_openacc && !(flag_openmp || flag_openmp_simd))
+	    {
+	      if (next_char () == '$')
+		{
+		  c = next_char ();
+		  if (c == 'a' || c == 'A')
+		    {
+		      if (skip_oacc_attribute_fixed (&start))
+			return;
 		    }
+		  else
+		    goto check_for_digits;
 		}
 	      gfc_current_locus = start;
 	    }
 
-	  if (flag_openacc)
+	  if (flag_openacc || (flag_openmp || flag_openmp_simd))
 	    {
 	      if (next_char () == '$')
 		{
 		  c = next_char ();
 		  if (c == 'a' || c == 'A')
 		    {
-		      if (((c = next_char ()) == 'c' || c == 'C')
-			  && ((c = next_char ()) == 'c' || c == 'C'))
-			{
-			  c = next_char ();
-			  if (c != '\n'
-			      && ((openacc_flag && continue_flag)
-				  || c == ' ' || c == '\t' || c == '0'))
-			    {
-			      do
-				c = next_char ();
-			      while (gfc_is_whitespace (c));
-			      if (c != '\n' && c != '!')
-				{
-				  /* Canonicalize to *$acc. */
-				  *start.nextc = '*';
-				  openacc_flag = 1;
-				  gfc_current_locus = start;
-				  return;
-				}
-			    }
-			}
+		      if (skip_oacc_attribute_fixed (&start))
+			return;
 		    }
-		  else
+		  else if (c == 'o' || c == 'O')
 		    {
-		      int digit_seen = 0;
-
-		      for (col = 3; col < 6; col++, c = next_char ())
-			if (c == ' ')
-			  continue;
-			else if (c == '\t')
-			  {
-			    col = 6;
-			    break;
-			  }
-			else if (c < '0' || c > '9')
-			  break;
-			else
-			  digit_seen = 1;
-
-		      if (col == 6 && c != '\n'
-			  && ((continue_flag && !digit_seen)
-			      || c == ' ' || c == '\t' || c == '0'))
-			{
-			  gfc_current_locus = start;
-			  start.nextc[0] = ' ';
-			  start.nextc[1] = ' ';
-			  continue;
-			}
+		      if (skip_omp_attribute_fixed (&start))
+			return;
 		    }
+		  else
+		    goto check_for_digits;
 		}
 	      gfc_current_locus = start;
 	    }
 
 	  skip_comment_line ();
 	  continue;
+
+	  gcc_unreachable ();
+check_for_digits:
+	  {
+	    int digit_seen = 0;
+
+	    for (col = 3; col < 6; col++, c = next_char ())
+	      if (c == ' ')
+		continue;
+	      else if (c == '\t')
+		{
+		  col = 6;
+		  break;
+		}
+	      else if (c < '0' || c > '9')
+		break;
+	      else
+		digit_seen = 1;
+
+	    if (col == 6 && c != '\n'
+		&& ((continue_flag && !digit_seen)
+		    || c == ' ' || c == '\t' || c == '0'))
+	      {
+		gfc_current_locus = start;
+		start.nextc[0] = ' ';
+		start.nextc[1] = ' ';
+		continue;
+	      }
+	    }
+	  skip_comment_line ();
+	  continue;
 	}
 
       if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
@@ -1321,7 +1342,7 @@ restart:
 	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
 
       if (flag_openmp)
-	if (prev_openmp_flag != openmp_flag)
+	if (prev_openmp_flag != openmp_flag && !openacc_flag)
 	  {
 	    gfc_current_locus = old_loc;
 	    openmp_flag = prev_openmp_flag;
@@ -1330,7 +1351,7 @@ restart:
 	  }
 
       if (flag_openacc)
-	if (prev_openacc_flag != openacc_flag)
+	if (prev_openacc_flag != openacc_flag && !openmp_flag)
 	  {
 	    gfc_current_locus = old_loc;
 	    openacc_flag = prev_openacc_flag;
@@ -1349,7 +1370,7 @@ restart:
       while (gfc_is_whitespace (c))
 	c = next_char ();
 
-      if (openmp_flag)
+      if (openmp_flag && !openacc_flag)
 	{
 	  for (i = 0; i < 5; i++, c = next_char ())
 	    {
@@ -1360,7 +1381,7 @@ restart:
 	  while (gfc_is_whitespace (c))
 	    c = next_char ();
 	}
-      if (openacc_flag)
+      if (openacc_flag && !openmp_flag)
 	{
 	  for (i = 0; i < 5; i++, c = next_char ())
 	    {
@@ -1372,6 +1393,26 @@ restart:
 	    c = next_char ();
 	}
 
+      /* In case we have an OpenMP directive continued by OpenACC
+	 sentinel, or vice versa, we get both openmp_flag and
+	 openacc_flag on.  */
+
+      if (openacc_flag && openmp_flag)
+	{
+	  int is_openmp = 0;
+	  for (i = 0; i < 5; i++, c = next_char ())
+	    {
+	      if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i])
+		is_openmp = 1;
+	      if (i == 4)
+		old_loc = gfc_current_locus;
+	    }
+	  gfc_error (is_openmp ? "Wrong OpenACC continuation at %C: "
+		     "expected !$ACC, got !$OMP"
+		     : "Wrong OpenMP continuation at %C: "
+		     "expected !$OMP, got !$ACC");
+	}
+
       if (c != '&')
 	{
 	  if (in_string)
@@ -1436,18 +1477,35 @@ restart:
       skip_fixed_comments ();
 
       /* See if this line is a continuation line.  */
-      if (flag_openmp && openmp_flag != prev_openmp_flag)
+      if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag)
 	{
 	  openmp_flag = prev_openmp_flag;
 	  goto not_continuation;
 	}
-      if (flag_openacc && openacc_flag != prev_openacc_flag)
+      if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag)
 	{
 	  openacc_flag = prev_openacc_flag;
 	  goto not_continuation;
 	}
 
-      if (!openmp_flag && !openacc_flag)
+      /* In case we have an OpenMP directive continued by OpenACC
+	 sentinel, or vice versa, we get both openmp_flag and
+	 openacc_flag on.  */
+      if (openacc_flag && openmp_flag)
+	{
+	  int is_openmp = 0;
+	  for (i = 0; i < 5; i++)
+	    {
+	      c = next_char ();
+	      if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
+		is_openmp = 1;
+	    }
+	  gfc_error (is_openmp ? "Wrong OpenACC continuation at %C: "
+		     "expected !$ACC, got !$OMP"
+		     : "Wrong OpenMP continuation at %C: "
+		     "expected !$OMP, got !$ACC");
+	}
+      else if (!openmp_flag && !openacc_flag)
 	for (i = 0; i < 5; i++)
 	  {
 	    c = next_char ();
diff --git gcc/testsuite/gfortran.dg/goacc/omp-fixed.f gcc/testsuite/gfortran.dg/goacc/omp-fixed.f
new file mode 100644
index 0000000..e715673
--- /dev/null
+++ gcc/testsuite/gfortran.dg/goacc/omp-fixed.f
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! { dg-additional-options "-fopenmp" }
+      SUBROUTINE ICHI
+      INTEGER :: ARGC
+      ARGC = COMMAND_ARGUMENT_COUNT ()
+
+!$OMP PARALLEL
+!$ACC PARALLEL                                                          &
+!$ACC& COPYIN(ARGC) ! { dg-error "directive cannot be specified within" }
+      IF (ARGC .NE. 0) THEN
+         CALL ABORT
+      END IF
+!$ACC END PARALLEL
+!$OMP END PARALLEL
+
+      END SUBROUTINE ICHI
+
+
+      SUBROUTINE NI
+      IMPLICIT NONE
+      INTEGER :: I
+
+!$ACC PARALLEL                                                          &
+!$OMP& DO ! { dg-error "Wrong OpenACC continuation" }
+      DO I = 1, 10
+      ENDDO
+
+!$OMP PARALLEL                                                          &
+!$ACC& LOOP ! { dg-error "Wrong OpenMP continuation" }
+      DO I = 1, 10
+      ENDDO
+      END SUBROUTINE NI
diff --git gcc/testsuite/gfortran.dg/goacc/omp.f95 gcc/testsuite/gfortran.dg/goacc/omp.f95
index 24f639f..339438a 100644
--- gcc/testsuite/gfortran.dg/goacc/omp.f95
+++ gcc/testsuite/gfortran.dg/goacc/omp.f95
@@ -63,4 +63,12 @@ contains
      !$omp end parallel
      !$acc end data
    end subroutine roku
-end module test
\ No newline at end of file
+
+   subroutine nana
+     !$acc parallel &
+     !$omp do ! { dg-error "Wrong OpenACC continuation" }
+
+     !$omp parallel &
+     !$acc loop ! { dg-error "Wrong OpenMP continuation" }
+   end subroutine nana
+end module test


GrÃÃe,
 Thomas

Attachment: signature.asc
Description: PGP signature