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

[Cesar Philippidis <cesar@codesourcery.com>]

[-- Attachment #1: Type: text/plain, Size: 2710 bytes --]

On 10/20/2015 02:37 AM, Jakub Jelinek wrote:
> On Fri, Oct 09, 2015 at 12:15:24PM +0200, Thomas Schwinge wrote:
>> 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)
> 
> Technically, this isn't attribute, but sentinel.
> So, skip_fixed_omp_sentinel?  I know the free functions
> are called attribute, perhaps we should rename them too,
> patch to do so preapproved.

I've renamed those functions in this patch. The free variants are named
skip_free_*_sentinel.

>> +{
>> +  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
> 
> The original code checked here
> 	(openmp_flag && continue_flag)
> instead.  Is that change intentional?

I think so. Without it, continuations won't work with -fopenmp-simd.
Note how that function call is guarded by

  if ((flag_openmp || flag_openmp_simd) && !flag_openacc)

> Looking around, we probably don't have a testcase coverage for say
> fixed form:
> 
> C*OMP+PARALLEL DO
> do ...

That's going to be tricky. In fixed mode, the only way that we can tell
if there is an omp/acc continuation is by inspecting the character at
position 6. So, there could be a comment like

C*ACCELERATOR

which would get picked up as an acc continuation.

> (i.e. where it starts with an OpenMP (or OpenACC) continuation, without
> non-continued line first), or for free form where:
> 
> something &
> !$omp & parallel
> 
> (ditto for OpenACC).

What type of error should this be reporting? Right now it does report an
error because this gets expanded to

something parallel

That's clearly not correct. But at the same time, it would still be an
error if the user placed !$omp/acc between a continuation.

>> +	  while (gfc_is_whitespace (c));
>> +	  if (c != '\n' && c != '!')
>> +	    {
>> +	      /* Canonicalize to *$omp.  */
> 
> The comment has a pasto, by storing * you canonicalize to *$acc.

Fixed.

>> -	  if (flag_openacc)
>> +	  if (flag_openacc || (flag_openmp || flag_openmp_simd))
> 
> I'd just write
> 	if (flag_openacc || flag_openmp || flag_openmp_simd)
> the ()s around are just misleading.
> 
> Anyway, if the removal of "openmp_flag &&" is intentional, then
> the patch is ok with the above mentioned changes.  We can deal with the
> cases I've mentioned up above in a follow-up.

I'll apply this patch shortly.

Cesar

[-- Attachment #2: gfc_openmp-openacc.diff --]
[-- Type: text/x-patch, Size: 12897 bytes --]

2015-11-24  Ilmir Usmanov <me@ilmir.us>
	    Cesar Philippidis  <cesar@codesourcery.com>

	gcc/fortran/

	PR fortran/63858
	* scanner.c (skip_oacc_attribute): Remove continue_flag parameter.
	Rename as ...
	(skip_free_oacc_sentinel): ... this.
	(skip_omp_attribute): Remove continue_flag parameter. Rename as ...
	(skip_free_omp_sentinel): ... this.
	(skip_free_comments): Update to call skip_free_oacc_sentinel and
	skip_free_omp_sentinel.
	(skip_fixed_omp_sentinel): New function.
	(skip_fixed_oacc_sentinel): New function.
	(skip_fixed_comments): Fix mix of OpenACC and OpenMP sentinels in
	continuation.

	gcc/testsuite/
	* goacc/omp-fixed.f: New test.
	* goacc/omp.f95: Add check for mis-matched omp and acc continuations.

diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c
index bfb7d45..8644119 100644
--- a/gcc/fortran/scanner.c
+++ b/gcc/fortran/scanner.c
@@ -712,7 +712,7 @@ skip_gcc_attribute (locus start)
 
 /* Return true if CC was matched.  */
 static bool
-skip_oacc_attribute (locus start, locus old_loc, bool continue_flag)
+skip_free_oacc_sentinel (locus start, locus old_loc)
 {
   bool r = false;
   char c;
@@ -752,7 +752,7 @@ skip_oacc_attribute (locus start, locus old_loc, bool continue_flag)
 
 /* Return true if MP was matched.  */
 static bool
-skip_omp_attribute (locus start, locus old_loc, bool continue_flag)
+skip_free_omp_sentinel (locus start, locus old_loc)
 {
   bool r = false;
   char c;
@@ -841,7 +841,7 @@ skip_free_comments (void)
 		    c = next_char ();
 		    if (c == 'o' || c == 'O')
 		      {
-			if (skip_omp_attribute (start, old_loc, continue_flag))
+			if (skip_free_omp_sentinel (start, old_loc))
 			  return false;
 			gfc_current_locus = old_loc;
 			next_char ();
@@ -849,7 +849,7 @@ skip_free_comments (void)
 		      }
 		    else if (c == 'a' || c == 'A')
 		      {
-			if (skip_oacc_attribute (start, old_loc, continue_flag))
+			if (skip_free_oacc_sentinel (start, old_loc))
 			  return false;
 			gfc_current_locus = old_loc;
 			next_char ();
@@ -874,7 +874,7 @@ skip_free_comments (void)
 		    c = next_char ();
 		    if (c == 'o' || c == 'O')
 		      {
-			if (skip_omp_attribute (start, old_loc, continue_flag))
+			if (skip_free_omp_sentinel (start, old_loc))
 			  return false;
 			gfc_current_locus = old_loc;
 			next_char ();
@@ -899,8 +899,7 @@ skip_free_comments (void)
 		    c = next_char ();
 		      if (c == 'a' || c == 'A')
 			{
-			  if (skip_oacc_attribute (start, old_loc, 
-						   continue_flag))
+			  if (skip_free_oacc_sentinel (start, old_loc))
 			    return false;
 			  gfc_current_locus = old_loc;
 			  next_char();
@@ -935,6 +934,63 @@ skip_free_comments (void)
   return false;
 }
 
+/* Return true if MP was matched in fixed form.  */
+static bool
+skip_fixed_omp_sentinel (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_fixed_oacc_sentinel (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 *$acc.  */
+	      *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 +1059,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_fixed_omp_sentinel (&start))
+			return;
 		    }
 		  else
+		    goto check_for_digits;
+		}
+	      gfc_current_locus = start;
+	    }
+
+	  if (flag_openacc && !(flag_openmp || flag_openmp_simd))
+	    {
+	      if (next_char () == '$')
+		{
+		  c = next_char ();
+		  if (c == 'a' || c == 'A')
 		    {
-		      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_fixed_oacc_sentinel (&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_fixed_oacc_sentinel (&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_fixed_omp_sentinel (&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 +1341,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 +1350,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 +1369,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 +1380,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 +1392,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 +1476,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 a/gcc/testsuite/gfortran.dg/goacc/omp-fixed.f b/gcc/testsuite/gfortran.dg/goacc/omp-fixed.f
new file mode 100644
index 0000000..e715673
--- /dev/null
+++ b/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 a/gcc/testsuite/gfortran.dg/goacc/omp.f95 b/gcc/testsuite/gfortran.dg/goacc/omp.f95
index 24f639f..339438a 100644
--- a/gcc/testsuite/gfortran.dg/goacc/omp.f95
+++ b/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