Re: [gomp4] Remove erroneous test and unreachable situation.

[James Norris <jnorris at codesourcery dot com>]

Hi,

The original patch still missed some situations (thanks Cesar!)
and the attached patch addresses those. It also adds some new
tests.

Jim

Index: libgomp/ChangeLog.gomp
===================================================================
--- libgomp/ChangeLog.gomp	(revision 228245)
+++ libgomp/ChangeLog.gomp	(working copy)
@@ -1,3 +1,7 @@
+2015-09-29  James Norris  <jnorris@codesourcery.com>
+
+	* testsuite/libgomp.oacc-fortran/routine-9.f90: New test.
+
 2015-09-29  Nathan Sidwell  <nathan@codesourcery.com>
 
 	* oacc-init.c (acc_on_device): Compile with optimization.
Index: libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90
===================================================================
--- libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90	(revision 0)
+++ libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90	(revision 0)
@@ -0,0 +1,31 @@
+! { dg-do run }
+! { dg-options "-fno-inline" }
+
+program main
+  implicit none
+  integer, parameter :: n = 10
+  integer :: a(n), i
+  integer, external :: fact
+  !$acc routine (fact)
+  !$acc parallel
+  !$acc loop
+  do i = 1, n
+     a(i) = fact (i)
+  end do
+  !$acc end parallel
+  do i = 1, n
+     if (a(i) .ne. fact(i)) call abort
+  end do
+end program main
+
+recursive function fact (x) result (res)
+  implicit none
+  !$acc routine (fact)
+  integer, intent(in) :: x
+  integer :: res
+  if (x < 1) then
+     res = 1
+  else
+     res = x * fact(x - 1)
+  end if
+end function fact
Index: gcc/testsuite/ChangeLog.gomp
===================================================================
--- gcc/testsuite/ChangeLog.gomp	(revision 228245)
+++ gcc/testsuite/ChangeLog.gomp	(working copy)
@@ -1,3 +1,7 @@
+2015-08-29  James Norris  <jnorris@codesourcery.com>
+
+	* gfortran.dg/goacc/routine-6.f90: New test.
+
 2015-09-29  Tom de Vries  <tom@codesourcery.com>
 
 	* c-c++-common/goacc/kernels-acc-loop-smaller-equal.c: New test.
Index: gcc/testsuite/gfortran.dg/goacc/routine-6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/goacc/routine-6.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/goacc/routine-6.f90	(revision 0)
@@ -0,0 +1,79 @@
+
+module m
+  integer m1int
+contains
+  subroutine subr5 (x) 
+  implicit none
+  !$acc routine (subr5)
+  !$acc routine (m1int) ! { dg-error "invalid function name" }
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+  end subroutine subr5
+end module m
+
+program main
+  implicit none
+  interface
+    function subr6 (x) 
+    !$acc routine (subr6) ! { dg-error "without list is allowed in interface" }
+    integer, intent (in) :: x
+    integer :: subr6
+    end function subr6
+  end interface
+  integer, parameter :: n = 10
+  integer :: a(n), i
+  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  external :: subr2
+  !$acc routine (subr2)
+  !$acc parallel
+  !$acc loop
+  do i = 1, n
+     call subr1 (i)
+     call subr2 (i)
+  end do
+  !$acc end parallel
+end program main
+
+subroutine subr1 (x) 
+  !$acc routine
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr1
+
+subroutine subr2 (x) 
+  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr2
+
+subroutine subr3 (x) 
+  !$acc routine (subr3)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     call subr4 (x)
+  end if
+end subroutine subr3
+
+subroutine subr4 (x) 
+  !$acc routine (subr4)
+  integer, intent(inout) :: x
+  if (x < 1) then
+     x = 1
+  else
+     x = x * x - 1
+  end if
+end subroutine subr4
Index: gcc/fortran/openmp.c
===================================================================
--- gcc/fortran/openmp.c	(revision 228245)
+++ gcc/fortran/openmp.c	(working copy)
@@ -1745,11 +1745,35 @@ gfc_match_oacc_routine (void)
 
   if (m == MATCH_YES)
     {
-      /* Scan for a function name/string.  */
-      m = gfc_match_symbol (&sym, 0);
+      char buffer[GFC_MAX_SYMBOL_LEN + 1];
+      gfc_symtree *st;
 
-      if (m == MATCH_NO)
+      m = gfc_match_name (buffer);
+      if (m == MATCH_YES)
 	{
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+	  if (st)
+	    {
+	      sym = st->n.sym;
+	      if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
+	        sym = NULL;
+	    }
+
+	  if (st == NULL
+	      || (sym
+		  && !sym->attr.external
+		  && !sym->attr.function
+		  && !sym->attr.subroutine))
+	    {
+	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
+			 "invalid function name %s",
+			 (sym) ? sym->name : buffer);
+	      gfc_current_locus = old_loc;
+	      return MATCH_ERROR;
+	    }
+	}
+      else
+        {
 	  gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
 	  gfc_current_locus = old_loc;
 	  return MATCH_ERROR;
@@ -1761,7 +1785,7 @@ gfc_match_oacc_routine (void)
 		     " ')' after NAME");
 	  gfc_current_locus = old_loc;
 	  return MATCH_ERROR;
-      }
+	}
     }
 
   if (gfc_match_omp_eos () != MATCH_YES
Index: gcc/fortran/ChangeLog.gomp
===================================================================
--- gcc/fortran/ChangeLog.gomp	(revision 228245)
+++ gcc/fortran/ChangeLog.gomp	(working copy)
@@ -1,3 +1,8 @@
+2015-09-29  James Norris  <jnorris@codesourcery.com>
+
+	* openmp.c (gfc_match_oacc_routine): Add additional attribute testing
+        and name option checking.
+
 2015-09-28  James Norris  <jnorris@codesourcery.com>
 
 	* openmp.c (gfc_match_oacc_routine): Remove erroneous attribute test