Fortran: Fix location_t in gfc_get_extern_function_decl; support 'omp dispatch interop'

The declaration created by gfc_get_extern_function_decl used input_location
as DECL_SOURCE_LOCATION, which gave rather odd results with 'declared here'
diagnostic. - It is much more useful to use the gfc_symbol's declated_at,
which this commit now does.

Additionally, it adds support for the 'interop' clause of OpenMP's
'dispatch' directive. As the argument order matters,
gfc_match_omp_variable_list gained a 'reverse_order' flag to use the
same order as the C/C++ parser.

gcc/fortran/ChangeLog:

	* gfortran.h: Add OMP_LIST_INTEROP to the unnamed OMP_LIST_ enum.
	* openmp.cc (gfc_match_omp_variable_list): Add reverse_order
	boolean argument, defaulting to false.
	(enum omp_mask2, OMP_DISPATCH_CLAUSES): Add OMP_CLAUSE_INTEROP.
	(gfc_match_omp_clauses, resolve_omp_clauses): Handle dispatch's
	'interop' clause.
	* trans-decl.cc (gfc_get_extern_function_decl): Use sym->declared_at
	instead input_location as DECL_SOURCE_LOCATION.
	* trans-openmp.cc (gfc_trans_omp_clauses): Handle OMP_LIST_INTEROP.

gcc/testsuite/ChangeLog:

	* gfortran.dg/goacc/routine-external-level-of-parallelism-2.f: Update
	xfail'ed 'dg-bogus' for the better 'declared here' location.
	* gfortran.dg/gomp/dispatch-11.f90: New test.
	* gfortran.dg/gomp/dispatch-12.f90: New test.

7 files changed, 195 insertions, 26 deletions

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index aa495b5..6293d85 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1467,6 +1467,7 @@ enum
   OMP_LIST_INIT,
   OMP_LIST_USE,
   OMP_LIST_DESTROY,
+  OMP_LIST_INTEROP,
   OMP_LIST_ADJUST_ARGS,
   OMP_LIST_NUM /* Must be the last.  */
 };
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 79c0f1b..e00044d 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -408,7 +408,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
 			     bool allow_sections = false,
 			     bool allow_derived = false,
 			     bool *has_all_memory = NULL,
-			     bool reject_common_vars = false)
+			     bool reject_common_vars = false,
+			     bool reverse_order = false)
 {
   gfc_omp_namelist *head, *tail, *p;
   locus old_loc, cur_loc;
@@ -492,15 +493,20 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
 	  p = gfc_get_omp_namelist ();
 	  if (head == NULL)
 	    head = tail = p;
+	  else if (reverse_order)
+	    {
+	      p->next = head;
+	      head = p;
+	    }
 	  else
 	    {
 	      tail->next = p;
 	      tail = tail->next;
 	    }
-	  tail->sym = sym;
-	  tail->expr = expr;
-	  tail->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
-						&gfc_current_locus);
+	  p->sym = sym;
+	  p->expr = expr;
+	  p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+					     &gfc_current_locus);
 	  if (reject_common_vars && sym->attr.in_common)
 	    {
 	      gcc_assert (allow_common);
@@ -540,13 +546,18 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
 	  p = gfc_get_omp_namelist ();
 	  if (head == NULL)
 	    head = tail = p;
+	  else if (reverse_order)
+	    {
+	      p->next = head;
+	      head = p;
+	    }
 	  else
 	    {
 	      tail->next = p;
 	      tail = tail->next;
 	    }
-	  tail->sym = sym;
-	  tail->where = cur_loc;
+	  p->sym = sym;
+	  p->where = cur_loc;
 	}
 
     next_item:
@@ -1128,6 +1139,7 @@ enum omp_mask2
   OMP_CLAUSE_USE,  /* OpenMP 5.1.  */
   OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1  */
   OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1  */
+  OMP_CLAUSE_INTEROP, /* OpenMP 5.1  */
   /* This must come last.  */
   OMP_MASK2_LAST
 };
@@ -3255,6 +3267,21 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
 		continue;
 	      goto error;
 	    }
+	  if ((mask & OMP_CLAUSE_INTEROP)
+	      && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
+					    "interop", true)) != MATCH_NO)
+	    {
+	      /* Note: the interop objects are saved in reverse order to match
+		 the order in C/C++.  */
+	      if (m == MATCH_YES
+		  && (gfc_match_omp_variable_list ("",
+						   &c->lists[OMP_LIST_INTEROP],
+						   false, NULL, NULL, false,
+						   false, NULL, false, true)
+		      == MATCH_YES))
+		continue;
+	      goto error;
+	    }
 	  if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
 	      && gfc_match_omp_variable_list
 		   ("is_device_ptr (",
@@ -5019,7 +5046,7 @@ cleanup:
 #define OMP_DISPATCH_CLAUSES                                                   \
   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS    \
    | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT       \
-   | OMP_CLAUSE_HAS_DEVICE_ADDR)
+   | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
 
 
 static match
@@ -8128,7 +8155,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	"DEVICE_RESIDENT", "LINK", "USE_DEVICE",
 	"CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
 	"NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
-	"USES_ALLOCATORS", "INIT", "USE", "DESTROY", "ADJUST_ARGS" };
+	"USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
   STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
 
   if (omp_clauses == NULL)
@@ -8455,6 +8482,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	&& list != OMP_LIST_DEPEND
 	&& list != OMP_LIST_FROM
 	&& list != OMP_LIST_TO
+	&& list != OMP_LIST_INTEROP
 	&& (list != OMP_LIST_REDUCTION || !openacc)
 	&& list != OMP_LIST_ALLOCATE)
       for (n = omp_clauses->lists[list]; n; n = n->next)
@@ -8553,8 +8581,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	    break;
 	  }
     }
-  if (code && code->op == EXEC_OMP_INTEROP)
-    for (list = OMP_LIST_INIT; list <= OMP_LIST_DESTROY; list++)
+  if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
+    for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP; list++)
       for (n = omp_clauses->lists[list]; n; n = n->next)
 	{
 	  if (n->sym->ts.type != BT_INTEGER
@@ -8564,7 +8592,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
 	    gfc_error ("%qs at %L in %qs clause must be a scalar integer "
 		       "variable of %<omp_interop_kind%> kind", n->sym->name,
 		       &n->where, clause_names[list]);
-	  if (list != OMP_LIST_USE && n->sym->attr.intent == INTENT_IN)
+	  if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
+	      && n->sym->attr.intent == INTENT_IN)
 	    gfc_error ("%qs at %L in %qs clause must be definable",
 		       n->sym->name, &n->where, clause_names[list]);
 	}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 814a205..4ae22a5 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2412,7 +2412,7 @@ module_sym:
 
   type = gfc_get_function_type (sym, actual_args, fnspec);
 
-  fndecl = build_decl (input_location,
+  fndecl = build_decl (gfc_get_location (&sym->declared_at),
 		       FUNCTION_DECL, name, type);
 
   /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index b04adf3..635fcfd 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2780,6 +2780,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 	case OMP_LIST_DESTROY:
 	  clause_code = OMP_CLAUSE_DESTROY;
 	  goto add_clause;
+	case OMP_LIST_INTEROP:
+	  clause_code = OMP_CLAUSE_INTEROP;
+	  goto add_clause;
 
 	add_clause:
 	  omp_clauses
diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f b/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
index 949d571..91898b1 100644
--- a/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
@@ -7,6 +7,13 @@
       integer, parameter :: n = 100
       integer :: a(n), i, j
       external :: gangr, workerr, vectorr, seqr
+! { dg-bogus "note: routine 'gangr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
+! { dg-bogus "note: routine 'gangr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
+! { dg-bogus "note: routine 'workerr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-3 }
+! { dg-bogus "note: routine 'workerr_' declared here" "TODO2" { xfail offloading_enabled } .-4 }
+! { dg-bogus "note: routine 'vectorr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-5 }
+! { dg-bogus "note: routine 'vectorr_' declared here" "TODO2" { xfail offloading_enabled } .-6 }
+
 !$acc routine (gangr) gang
 !$acc routine (workerr) worker
 !$acc routine (vectorr) vector
@@ -22,8 +29,6 @@
 ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 }
          do j = 1, n
             call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
-! { dg-bogus "note: routine 'workerr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'workerr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
          end do
       end do
 !$acc end parallel loop
@@ -36,8 +41,6 @@
          do j = 1, n
             call gangr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 }
-! { dg-bogus "note: routine 'gangr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 }
-! { dg-bogus "note: routine 'gangr_' declared here" "TODO2" { xfail offloading_enabled } .-3 }
          end do
       end do
 !$acc end parallel loop
@@ -162,8 +165,6 @@
 !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" }
       do i = 1, n
          call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" }
-! { dg-bogus "note: routine 'vectorr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'vectorr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
       end do
 !$acc end parallel loop
 
@@ -199,6 +200,13 @@
       integer, parameter :: n = 100
       integer :: a(n), i, j
       integer, external :: gangf, workerf, vectorf, seqf
+! { dg-bogus "note: routine 'gangf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
+! { dg-bogus "note: routine 'gangf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
+! { dg-bogus "note: routine 'workerf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-3 }
+! { dg-bogus "note: routine 'workerf_' declared here" "TODO2" { xfail offloading_enabled } .-4 }
+! { dg-bogus "note: routine 'vectorf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-5 }
+! { dg-bogus "note: routine 'vectorf_' declared here" "TODO2" { xfail offloading_enabled } .-6 }
+
 !$acc routine (gangf) gang
 !$acc routine (workerf) worker
 !$acc routine (vectorf) vector
@@ -214,8 +222,6 @@
 ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 }
          do j = 1, n
             a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
-! { dg-bogus "note: routine 'workerf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'workerf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
          end do
       end do
 !$acc end parallel loop
@@ -228,9 +234,7 @@
          do j = 1, n
             a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 }
-! { dg-bogus "note: routine 'gangf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 }
-! { dg-bogus "note: routine 'gangf_' declared here" "TODO2" { xfail offloading_enabled } .-3 }
-         end do
+        end do
       end do
 !$acc end parallel loop
 
@@ -354,8 +358,6 @@
 !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" }
       do i = 1, n
          a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" }
-! { dg-bogus "note: routine 'vectorf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'vectorf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
       end do
 !$acc end parallel loop
 
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90
new file mode 100644
index 0000000..2a909a3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90
@@ -0,0 +1,85 @@
+! { dg-additional-options "-fdump-tree-original"  }
+
+! The following definitions are in omp_lib, which cannot be included
+! in gcc/testsuite/
+
+module m
+  use iso_c_binding
+  implicit none (type, external)
+
+  integer, parameter :: omp_interop_kind = c_intptr_t
+  integer, parameter :: omp_interop_none = 0_omp_interop_kind
+
+  interface
+    real function repl1(); end  ! { dg-note "'declare variant' candidate 'repl1' declared here" }
+
+    real function base1()
+! { dg-note "'base1' declared here" "" { target *-*-* } .-1 }
+      !$omp declare variant(repl1) match(construct={dispatch})
+    end
+
+    subroutine repl2 (x1, x2)  ! { dg-note "'declare variant' candidate 'repl2' declared here" }
+      import
+      type(c_ptr), value :: x1, x2
+    end
+    subroutine base2 (x, y)
+! { dg-note "'base2' declared here" "" { target *-*-* } .-1 }
+      import
+      type(c_ptr), value :: x, y
+      !$omp declare variant(repl2) match(construct={dispatch}) adjust_args(need_device_ptr : y)
+    end
+  end interface
+
+contains
+
+real function dupl (a, b)
+  type(c_ptr), value :: a, b
+  integer(omp_interop_kind) :: obj1, obj2
+  real :: x
+
+  !$omp dispatch interop ( obj1, obj2) device(2)
+    x = base1 ()
+  ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+  !$omp dispatch device(9) interop ( obj1, obj2) nocontext(.true.)
+    call base2 (a, b)
+  ! { dg-error "unexpected 'interop' clause as invoked procedure 'base2' is not variant substituted" "" { target *-*-* } .-1 }
+  dupl = x
+end
+
+real function test (a, b)
+  type(c_ptr), value :: a, b
+  integer(omp_interop_kind) :: obj1, obj2
+  real :: x, y
+
+  !$omp dispatch interop ( obj1 )
+    x = base1 ()
+  ! { dg-error "number of list items in 'interop' clause \\(1\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+  !$omp dispatch interop ( obj1, obj1 ) device(42) ! Twice the same - should be fine.
+    x = base1 ()
+  ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+  !$omp dispatch novariants(.true.) interop(obj2, obj1) device(0)
+    y = base1 ()
+  ! { dg-error "unexpected 'interop' clause as invoked procedure 'base1' is not variant substituted" "" { target *-*-* } .-1 }
+
+  !$omp dispatch interop(obj2, obj1) device(3)
+    call base2 (a, b)
+  ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl2'" "" { target *-*-* } .-1 }
+
+  !$omp dispatch interop(obj2) nocontext(.true.)
+    call base2 (a, b)
+  ! { dg-error "unexpected 'interop' clause as invoked procedure 'base2' is not variant substituted" "" { target *-*-* } .-1 }
+  test = x + y
+end
+end module
+
+
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) interop\\(obj1\\) device\\(2\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) interop\\(obj1\\) nocontext\\(1\\) device\\(9\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj1\\) device\\(42\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj2\\) novariants\\(1\\) device\\(0\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj2\\) device\\(3\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) nocontext\\(1\\)\[\\n\\r\]" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90 b/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90
new file mode 100644
index 0000000..93304a6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90
@@ -0,0 +1,49 @@
+! The following definitions are in omp_lib, which cannot be included
+! in gcc/testsuite/
+
+module m
+  use iso_c_binding
+  implicit none (type, external)
+
+  integer, parameter :: omp_interop_kind = c_intptr_t
+  integer, parameter :: omp_interop_none = 0_omp_interop_kind
+
+  interface
+    subroutine repl1(); end
+
+    subroutine base1()
+      !$omp declare variant(repl1) match(construct={dispatch})
+    end
+  end interface
+
+contains
+  subroutine test (obj1)
+    integer(omp_interop_kind), intent(in) :: obj1
+    integer(omp_interop_kind) :: obj2(2)
+    integer(omp_interop_kind), parameter :: obj3 = omp_interop_none
+    integer(1) :: x
+
+    !$omp dispatch interop ( obj1, obj2, obj1 ) device(2) ! { dg-error "'obj2' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+      call base1 ()
+
+    !$omp dispatch interop ( obj1, obj1, obj1 ) device(2) ! OK
+      call base1 ()
+
+    !$omp dispatch interop ( obj3 ) ! { dg-error "Object 'obj3' is not a variable at .1." }
+      call base1 ()
+      ! { dg-error "'obj3' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" "" { target *-*-* } .-2 }
+
+    !$omp dispatch interop ( obj1 )
+      call base1 ()
+
+    !$omp dispatch interop ( obj2 )  ! { dg-error "'obj2' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+      call base1 ()
+
+    !$omp dispatch interop ( x )  ! { dg-error "'x' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+      call base1 ()
+
+    !$omp dispatch interop ( obj1) device(2) interop (obj1 ) ! { dg-error "Duplicated 'interop' clause" }
+      call base1 ()
+
+  end
+end module