Fortran/OpenMP: Fix declare_variant's 'adjust_args' mishandling with return by refere...

declare_variant's 'adjust_args' clause references the arguments in the
middle end by the argument position; this has to account for hidden
arguments that are inserted before due to return by reference,
as done in this commit.

	PR fortran/118321

gcc/fortran/ChangeLog:

	* trans-openmp.cc (gfc_trans_omp_declare_variant): Honor hidden
	arguments for append_arg's need_device_ptr.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/adjust-args-12.f90: New test.

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 2c6192820cc69cf9efe4dbb4e1e2e88b346b2fbf..d3ebc9b47455431c391789858946b7f91bad6955 100644 (file)
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -8622,7 +8622,7 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
          if (!search_ns->proc_name->attr.function
              && !search_ns->proc_name->attr.subroutine)
            gfc_error ("The base name for %<declare variant%> must be "
-                      "specified at %L ", &odv->where);
+                      "specified at %L", &odv->where);
          else
            error_found = false;
        }
@@ -8821,6 +8821,13 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
                  // Handle adjust_args
                  tree need_device_ptr_list = make_node (TREE_LIST);
                  vec<gfc_symbol *> adjust_args_list = vNULL;
+                 int arg_idx_offset = 0;
+                 if (gfc_return_by_reference (ns->proc_name))
+                   {
+                     arg_idx_offset++;
+                     if (ns->proc_name->ts.type == BT_CHARACTER)
+                       arg_idx_offset++;
+                   }
                  for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
                       arg_list != NULL; arg_list = arg_list->next)
                    {
@@ -8847,14 +8854,15 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
                            if (arg->sym == arg_list->sym)
                              break;
                          gcc_assert (arg != NULL);
+                         // Store 0-based argument index,
+                         // as in gimplify_call_expr
                          need_device_ptr_list = chainon (
                            need_device_ptr_list,
                            build_tree_list (
                              NULL_TREE,
                              build_int_cst (
                                integer_type_node,
-                               idx))); // Store 0-based argument index,
-                                       // as in gimplify_call_expr
+                               idx + arg_idx_offset)));
                        }
                    }
 

diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-12.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-12.f90
new file mode 100644 (file)
index 0000000..94fdd6c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-12.f90
@@ -0,0 +1,40 @@
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! PR fortran/118321
+
+! Ensure that hidden arguments (return by reference) do not mess up the
+! argument counting of need_device_ptr
+
+! Here, we want to process the 3rd argument: 'c' as dummy argument = 'y' as actual.
+
+
+! { dg-final { scan-tree-dump-times "__builtin_omp_get_mapped_ptr" 1 "gimple" } }
+! { dg-final { scan-tree-dump "D\.\[0-9\]+ = __builtin_omp_get_mapped_ptr \\(y, D\.\[0-9\]+\\);" "gimple" } }
+
+! { dg-final { scan-tree-dump "ffff \\(&pstr.\[0-9\], &slen.\[0-9\], &\"abc\"\\\[1\\\]\{lb: 1 sz: 1\}, x, D\.\[0-9\]+, z, &\"cde\"\\\[1\\\]\{lb: 1 sz: 1\}, 3, 3\\);" "gimple" } }
+
+module m
+  use iso_c_binding
+  implicit none (type, external)
+contains
+  character(:) function ffff (a,b,c,d,e)
+    allocatable :: ffff
+    character(*) :: a, e
+    type(c_ptr), value :: b,c,d
+  end
+  character(:) function gggg (a,b,c,d,e)
+    !$omp declare variant(ffff) match(construct={dispatch})  &
+    !$omp&                      adjust_args(need_device_ptr : c)
+    allocatable :: gggg
+    character(*) :: a, e
+    type(c_ptr), value :: b,c,d
+  end
+end module m
+
+use m
+implicit none (type, external)
+type(c_ptr) :: x,y,z
+character(len=:), allocatable :: str
+!$omp dispatch
+  str = gggg ("abc", x, y, z, "cde")
+end