From f6bf4bc14d8ab24acad0b0d42cde5e08d1c3a879 Mon Sep 17 00:00:00 2001
From: Thomas Schwinge <thomas@codesourcery.com>
Date: Thu, 21 Mar 2019 21:02:42 +0100
Subject: [PATCH] [PR89773] Fortran OpenACC 'routine' directive refuses
 procedures with implicit EXTERNAL attribute

	gcc/fortran/
	PR fortran/89773
	* gfortran.h (gfc_oacc_routine_name): Add loc member.
	(gfc_resolve_oacc_routines): Declare.
	* openmp.c (gfc_match_oacc_routine): Move some error checking
	into...
	(gfc_resolve_oacc_routines): ... this new function.
	* resolve.c (resolve_codes): Call it.
	gcc/testsuite/
	PR fortran/89773
	* gfortran.dg/goacc/pr89773.f90: New file.
	* gfortran.dg/goacc/pr77765.f90: Adjust.
	* gfortran.dg/goacc/routine-6.f90: Adjust, and extend.

From-SVN: r269857
---
 gcc/fortran/ChangeLog                         |  8 ++++++
 gcc/fortran/gfortran.h                        |  2 ++
 gcc/fortran/openmp.c                          | 33 ++++++++++++++++++------
 gcc/fortran/resolve.c                         |  1 +
 gcc/testsuite/ChangeLog                       |  5 ++++
 gcc/testsuite/gfortran.dg/goacc/pr77765.f90   |  2 +-
 gcc/testsuite/gfortran.dg/goacc/pr89773.f90   | 36 +++++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/goacc/routine-6.f90 | 21 +++++++++++++---
 8 files changed, 96 insertions(+), 12 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr89773.f90

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 111e3a2..7ce67eb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,13 @@
 2019-03-21  Thomas Schwinge  <thomas@codesourcery.com>
 
+	PR fortran/89773
+	* gfortran.h (gfc_oacc_routine_name): Add loc member.
+	(gfc_resolve_oacc_routines): Declare.
+	* openmp.c (gfc_match_oacc_routine): Move some error checking
+	into...
+	(gfc_resolve_oacc_routines): ... this new function.
+	* resolve.c (resolve_codes): Call it.
+
 	PR fortran/72741
 	* openmp.c (gfc_match_oacc_routine): Clarify.
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2f55b9c..caf5e52 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1739,6 +1739,7 @@ typedef struct gfc_oacc_routine_name
   struct gfc_symbol *sym;
   struct gfc_omp_clauses *clauses;
   struct gfc_oacc_routine_name *next;
+  locus loc;
 }
 gfc_oacc_routine_name;
 
@@ -3210,6 +3211,7 @@ void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_declare (gfc_namespace *);
 void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *);
 void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_oacc_routines (gfc_namespace *);
 
 /* expr.c */
 void gfc_free_actual_arglist (gfc_actual_arglist *);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 1b1a0b4..983b83d 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2322,15 +2322,10 @@ gfc_match_oacc_routine (void)
 	        sym = NULL;
 	    }
 
-	  if ((isym == NULL && st == NULL)
-	      || (sym
-		  && !sym->attr.external
-		  && !sym->attr.function
-		  && !sym->attr.subroutine))
+	  if (isym == NULL && st == NULL)
 	    {
-	      gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
-			 "invalid function name %s",
-			 (sym) ? sym->name : buffer);
+	      gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
+			 buffer);
 	      gfc_current_locus = old_loc;
 	      return MATCH_ERROR;
 	    }
@@ -2400,6 +2395,7 @@ gfc_match_oacc_routine (void)
 	  n->sym = sym;
 	  n->clauses = c;
 	  n->next = gfc_current_ns->oacc_routine_names;
+	  n->loc = old_loc;
 	  gfc_current_ns->oacc_routine_names = n;
 	}
     }
@@ -6072,6 +6068,27 @@ gfc_resolve_oacc_declare (gfc_namespace *ns)
     }
 }
 
+
+void
+gfc_resolve_oacc_routines (gfc_namespace *ns)
+{
+  for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
+       orn;
+       orn = orn->next)
+    {
+      gfc_symbol *sym = orn->sym;
+      if (!sym->attr.external
+	  && !sym->attr.function
+	  && !sym->attr.subroutine)
+	{
+	  gfc_error ("NAME %qs does not refer to a subroutine or function"
+		     " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
+	  continue;
+	}
+    }
+}
+
+
 void
 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
 {
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7539aa7..e1cd200 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -16818,6 +16818,7 @@ resolve_codes (gfc_namespace *ns)
   bitmap_obstack_initialize (&labels_obstack);
 
   gfc_resolve_oacc_declare (ns);
+  gfc_resolve_oacc_routines (ns);
   gfc_resolve_omp_local_vars (ns);
   gfc_resolve_code (ns->code, ns);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0c94f6b..e771a87 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2019-03-21  Thomas Schwinge  <thomas@codesourcery.com>
 
+	PR fortran/89773
+	* gfortran.dg/goacc/pr89773.f90: New file.
+	* gfortran.dg/goacc/pr77765.f90: Adjust.
+	* gfortran.dg/goacc/routine-6.f90: Adjust, and extend.
+
 	PR fortran/72741
 	* gfortran.dg/goacc/routine-module-mod-1.f90: Update.
 
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr77765.f90 b/gcc/testsuite/gfortran.dg/goacc/pr77765.f90
index afa0a56..e0ea391 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr77765.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/pr77765.f90
@@ -14,5 +14,5 @@ end module m
 
 ! { dg-error "Procedure 'f' at .1. is already defined" "" { target *-*-* } 8 }
 ! { dg-error ".1." "" { target *-*-* } 10 }
-! { dg-error "Syntax error in ..ACC ROUTINE . NAME . at .1., invalid function name f" "" { target *-*-* } 11 }
+! { dg-error "Invalid NAME 'f' in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } 11 }
 ! { dg-error "Expecting END MODULE statement" "" { target *-*-* } 12 }
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr89773.f90 b/gcc/testsuite/gfortran.dg/goacc/pr89773.f90
new file mode 100644
index 0000000..e0e5c4f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/pr89773.f90
@@ -0,0 +1,36 @@
+! Valid usage of 'external' procedures with OpenACC 'routine' directives.
+
+! { dg-additional-options "-fdump-tree-optimized-raw" }
+
+  subroutine test (x)
+    implicit none
+    integer, intent(inout) :: x
+    !$acc routine (test)
+
+    integer, external :: f_1
+    !$acc routine (f_1)
+
+    integer f_2 ! No explicit EXTERNAL attribute.
+    !$acc routine (f_2)
+
+    external s_1
+    !$acc routine (s_1)
+
+    ! 's_2' will be an external subroutine without explicit EXTERNAL
+    ! attribute, but we don't have a handle for it yet...
+    !!$acc routine (s_2) ..., so can't specify this, here.
+
+    if (x < 1) then
+       x = 1
+    else
+       x = x * x - 1 + f_1(f_2(x))
+       call s_1(x)
+       call s_2(x)
+    end if
+  end subroutine test
+
+! { dg-final { scan-tree-dump-times "gimple_call" 4 "optimized" } }
+! { dg-final { scan-tree-dump-times "gimple_call <f_1," 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "gimple_call <f_2," 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "gimple_call <s_1," 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "gimple_call <s_2," 1 "optimized" } }
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
index 0201b8d..cdf643f 100644
--- a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90
@@ -5,19 +5,30 @@ module m
 contains
   subroutine subr5 (x) 
   implicit none
+  !$acc routine (m) ! { dg-error "Invalid NAME 'm' in \\!\\\$ACC ROUTINE \\( NAME \\)" }
   !$acc routine (subr5)
-  !$acc routine (m1int) ! { dg-error "invalid function name" }
+  !$acc routine (m1int) ! { dg-error "Invalid NAME 'm1int' in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  integer f_1 ! Referenced.
+  !$acc routine (f_1)
+  integer f_2 ! Not referenced.
+  !$acc routine (f_2) ! { dg-error "NAME 'f_2' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  integer v_1
+  !$acc routine (v_1) ! { dg-error "NAME 'v_1' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
   integer, intent(inout) :: x
+  !$acc routine (x) ! { dg-error "NAME 'x' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  v_1 = x
   if (x < 1) then
      x = 1
   else
      x = x * x - 1
+     x = f_1(x) + v_1
   end if
   end subroutine subr5
 end module m
 
 program main
   implicit none
+  !$acc routine (main) ! { dg-error "PROGRAM attribute conflicts with SUBROUTINE attribute in 'main'" }
   interface
     function subr6 (x) 
     !$acc routine (subr6) ! { dg-error "without list is allowed in interface" }
@@ -27,7 +38,10 @@ program main
   end interface
   integer, parameter :: n = 10
   integer :: a(n), i
-  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  !$acc routine (n) ! { dg-error "NAME 'n' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  !$acc routine (a) ! { dg-error "NAME 'a' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  !$acc routine (i) ! { dg-error "NAME 'i' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
+  !$acc routine (subr1) ! { dg-error "Invalid NAME 'subr1' in \\!\\\$ACC ROUTINE \\( NAME \\)" }
   external :: subr2
   !$acc routine (subr2)
 
@@ -63,8 +77,9 @@ subroutine subr1 (x)
 end subroutine subr1
 
 subroutine subr2 (x) 
-  !$acc routine (subr1) ! { dg-error "invalid function name" }
+  !$acc routine (subr1) ! { dg-error "Invalid NAME 'subr1' in \\!\\\$ACC ROUTINE \\( NAME \\)" }
   integer, intent(inout) :: x
+  !$acc routine (x) ! { dg-error "NAME 'x' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" }
   if (x < 1) then
      x = 1
   else
-- 
2.7.4