Hi all,
on the fixes side: If a function only appeared in an INTERFACE block,
the declare variant handling wasn't triggered - i.e. all diagnostic
handled there wasn't.
Additionally, when it was written as such in a module - and the module
got used, it wasn't active such that the wrong (the non variant function)
was called.
This patch handles the INTERFACE block issue of PR115271. The problem
that declare variant is not saved in the .mod file still remains.
Additionally, when looking at the code, I found a superfluous and wrong
check for 'dispatch' - rejecting potentially valid code (example of such
included).
And it add some feature support by implementing OpenMP 6.0's
adjust_args changes - namely, taking an integer (literal?) instead of
the dummy argument name - or a numeric range with const expressions and/or
'omp_num_args'. And 'need_device_addr' - however, it currently stops before
actually handling the latter by printing a sorry, not yet implemented.
[It needs some larger tweaks to handle optional + array descriptors properly.
For the C/C++ side, see also PR c++/118859.]
Finally, 'type(C_ptr) :: array(:)' is now rejected with need_device_ptr
as that's not a simple pointer but uses an array descriptor. That is
supposed to work with need_device_addr, though. On the OpenMP side,
that was fixed after 6.0 via OpenMP spec Issue #4443.
Comments, remarks, suggestions before I commit it?
(Build & regtested on x86-64_gnu-linux without offloading.
Tobias
PS: Follow-up work to be done in that area:
- Writing 'omp declare variant' to .mod files → PR115271
[wrong-code issue]
- Handling need_device_addr + fixing wrong-code part of
PR c++/118859 (relate; fixing the diagnostic should also be done)
[wrong-code + feature issue; for C++ also diagnostic/accepts-invalid]
- Adding some more valid testcases (as part of ↑?)
[also useful]
OpenMP/Fortran: extend 'adjust_args' clause, fixes for it and declare variant [PR115271]
On the extension side, it implements OpenMP 6.0's numeric values/ranges for
the adjust_args arguments, including 'omp_num_args'. And it adds parser
support for need_device_addr. It also implements the post-OpenMP-6.0
clarification of OpenMP spec Issue #4443 regarding type(c_ptr) with
dimension being invalid for need_device_ptr.
To be done: Adding full support for need_device_addr (optional, array
descriptor, ...).
On the invalid side, it removed a bogus c_ptr check that went through
all adjust_args without checking for need_device_ptr and the current scope.
And it finally also processes 'declare variant' in an INTERFACE block,
which is part of PR115271, but it does not handle .mod file yet - the
main issue tracked in that PR.
PR fortran/115271
gcc/fortran/ChangeLog:
* gfortran.h (gfc_omp_namelist): Change need_device_ptr to adj_args
union and add more flags.
* openmp.cc (gfc_match_omp_declare_variant,
gfc_resolve_omp_declare): For adjust_args, handle need_device_addr
and numeric values/ranges besides dummy argument names.
(resolve_omp_dispatch): Remove bogus a adjust_args check.
* trans-decl.cc (gfc_handle_declare_variant): New.
(gfc_generate_module_vars, gfc_generate_function_code): Call it.
* trans-openmp.cc (gfc_trans_omp_declare_variant): Handle numeric
values/ranges besides dummy argument names.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/adjust-args-1.f90: Update dg-.* expectations.
* gfortran.dg/gomp/adjust-args-2.f90: Likewise.
* gfortran.dg/gomp/adjust-args-2a.f90: Likewise.
* gfortran.dg/gomp/adjust-args-3.f90: Likewise.
* gfortran.dg/gomp/adjust-args-4.f90: Remove array from c_ptr.
* gfortran.dg/gomp/adjust-args-5.f90: Likewise.
* gfortran.dg/gomp/adjust-args-11.f90: Likewise. Add check that
INTERFACE is now handled in subroutines and in modules.
* gfortran.dg/gomp/adjust-args-13.f90: New test.
* gfortran.dg/gomp/adjust-args-14.f90: New test.
* gfortran.dg/gomp/adjust-args-15.f90: New test.
* gfortran.dg/gomp/declare-variant-21.f90: New test.
gcc/fortran/gfortran.h | 10 +-
gcc/fortran/openmp.cc | 247 +++++++++++++++++----
gcc/fortran/trans-decl.cc | 23 ++
gcc/fortran/trans-openmp.cc | 212 ++++++++++++++----
gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 | 8 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-11.f90 | 77 ++++++-
gcc/testsuite/gfortran.dg/gomp/adjust-args-13.f90 | 18 ++
gcc/testsuite/gfortran.dg/gomp/adjust-args-14.f90 | 85 +++++++
gcc/testsuite/gfortran.dg/gomp/adjust-args-15.f90 | 35 +++
gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 | 3 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90 | 8 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 | 8 +-
gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 | 8 +-
.../gfortran.dg/gomp/declare-variant-21.f90 | 20 ++
15 files changed, 660 insertions(+), 106 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5fe12764615..557c5c76f41 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1412,7 +1412,15 @@ typedef struct gfc_omp_namelist
bool target;
bool targetsync;
} init;
- bool need_device_ptr;
+ struct
+ {
+ bool need_ptr:1;
+ bool need_addr:1;
+ bool range_start:1;
+ bool omp_num_args_plus:1;
+ bool omp_num_args_minus:1;
+ bool error_p:1;
+ } adj_args;
} u;
union
{
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index e8df9d63fec..c30ab997f76 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -6718,21 +6718,21 @@ gfc_match_omp_declare_variant (void)
enum clause
{
- match,
- adjust_args,
- append_args
+ clause_match,
+ clause_adjust_args,
+ clause_append_args
} ccode;
if (gfc_match ("match") == MATCH_YES)
- ccode = match;
+ ccode = clause_match;
else if (gfc_match ("adjust_args") == MATCH_YES)
{
- ccode = adjust_args;
+ ccode = clause_adjust_args;
adjust_args_loc = gfc_current_locus;
}
else if (gfc_match ("append_args") == MATCH_YES)
{
- ccode = append_args;
+ ccode = clause_append_args;
append_args_loc = gfc_current_locus;
}
else
@@ -6741,13 +6741,13 @@ gfc_match_omp_declare_variant (void)
break;
}
- if (gfc_match (" (") != MATCH_YES)
+ if (gfc_match (" ( ") != MATCH_YES)
{
gfc_error ("expected %<(%> at %C");
return MATCH_ERROR;
}
- if (ccode == match)
+ if (ccode == clause_match)
{
if (has_match)
{
@@ -6766,32 +6766,160 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
}
- else if (ccode == adjust_args)
+ else if (ccode == clause_adjust_args)
{
has_adjust_args = true;
- bool need_device_ptr_p;
- if (gfc_match (" nothing") == MATCH_YES)
- need_device_ptr_p = false;
- else if (gfc_match (" need_device_ptr") == MATCH_YES)
+ bool need_device_ptr_p = false;
+ bool need_device_addr_p = false;
+ if (gfc_match ("nothing ") == MATCH_YES)
+ ;
+ else if (gfc_match ("need_device_ptr ") == MATCH_YES)
need_device_ptr_p = true;
+ else if (gfc_match ("need_device_addr ") == MATCH_YES)
+ need_device_addr_p = true;
else
{
- gfc_error ("expected %<nothing%> or %<need_device_ptr%> at %C");
+ gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
+ "%<need_device_addr%> at %C");
return MATCH_ERROR;
}
- gfc_omp_namelist **head = NULL;
- if (gfc_match_omp_variable_list (" :", &odv->adjust_args_list, false,
- NULL, &head)
- != MATCH_YES)
+ if (gfc_match (": ") != MATCH_YES)
{
- gfc_error ("expected argument list at %C");
+ gfc_error ("expected %<:%> at %C");
return MATCH_ERROR;
}
- if (need_device_ptr_p)
- for (gfc_omp_namelist *n = *head; n != NULL; n = n->next)
- n->u.need_device_ptr = true;
+ gfc_omp_namelist *tail = NULL;
+ bool need_range = false, have_range = false;
+ while (true)
+ {
+ gfc_omp_namelist *p = gfc_get_omp_namelist ();
+ p->where = gfc_current_locus;
+ p->u.adj_args.need_ptr = need_device_ptr_p;
+ p->u.adj_args.need_addr = need_device_addr_p;
+ if (tail)
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ else
+ {
+ gfc_omp_namelist **q = &odv->adjust_args_list;
+ if (*q)
+ {
+ for (; (*q)->next; q = &(*q)->next)
+ ;
+ (*q)->next = p;
+ }
+ else
+ *q = p;
+ tail = p;
+ }
+ if (gfc_match (": ") == MATCH_YES)
+ {
+ if (have_range)
+ {
+ gfc_error ("unexpected %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ p->u.adj_args.range_start = have_range = true;
+ need_range = false;
+ continue;
+ }
+ if (have_range && gfc_match (", ") == MATCH_YES)
+ {
+ have_range = false;
+ continue;
+ }
+ if (have_range && gfc_match (") ") == MATCH_YES)
+ break;
+ locus saved_loc = gfc_current_locus;
+
+ /* Without ranges, only arg names or integer literals permitted;
+ handle literals here as gfc_match_expr simplifies the expr. */
+ if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
+ {
+ gfc_gobble_whitespace ();
+ char c = gfc_peek_ascii_char ();
+ if (c != ')' && c != ',' && c != ':')
+ {
+ gfc_free_expr (p->expr);
+ p->expr = NULL;
+ gfc_current_locus = saved_loc;
+ }
+ }
+ if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
+ {
+ if (!have_range)
+ p->u.adj_args.range_start = need_range = true;
+ else
+ need_range = false;
+
+ locus saved_loc2 = gfc_current_locus;
+ gfc_gobble_whitespace ();
+ char c = gfc_peek_ascii_char ();
+ if (c == '+' || c == '-')
+ {
+ if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
+ p->u.adj_args.omp_num_args_plus = true;
+ else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
+ p->u.adj_args.omp_num_args_minus = true;
+ else if (!gfc_error_check ())
+ {
+ gfc_error ("expected constant integer expression "
+ "at %C");
+ p->u.adj_args.error_p = true;
+ return MATCH_ERROR;
+ }
+ p->where = gfc_get_location_range (&saved_loc, 1,
+ &saved_loc, 1,
+ &gfc_current_locus);
+ }
+ else
+ {
+ p->where = gfc_get_location_range (&saved_loc, 1,
+ &saved_loc, 1,
+ &saved_loc2);
+ p->u.adj_args.omp_num_args_plus = true;
+ }
+ }
+ else if (!p->expr)
+ {
+ match m = gfc_match_expr (&p->expr);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected dummy parameter name, "
+ "%<omp_num_args%> or constant positive integer"
+ " at %C");
+ p->u.adj_args.error_p = true;
+ return MATCH_ERROR;
+ }
+ if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
+ need_range = true; /* Constant expr but not literal. */
+ p->where = p->expr->where;
+ }
+ else
+ p->where = p->expr->where;
+ gfc_gobble_whitespace ();
+ match m = gfc_match (": ");
+ if (need_range && m != MATCH_YES)
+ {
+ gfc_error ("expected %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ if (m == MATCH_YES)
+ {
+ p->u.adj_args.range_start = have_range = true;
+ need_range = false;
+ continue;
+ }
+ need_range = have_range = false;
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ }
}
- else if (ccode == append_args)
+ else if (ccode == clause_append_args)
{
if (has_append_args)
{
@@ -12817,18 +12945,6 @@ resolve_omp_dispatch (gfc_code *code)
gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
"procedure pointer",
&code->loc);
-
- gfc_omp_declare_variant *odv = gfc_current_ns->omp_declare_variant;
- if (odv != NULL)
- for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
- if (n->sym->ts.type != BT_DERIVED || !n->sym->ts.u.derived->ts.is_iso_c
- || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR))
- {
- gfc_error (
- "argument list item %qs in %<need_device_ptr%> at %L must be of "
- "TYPE(C_PTR)",
- n->sym->name, &n->where);
- }
}
/* Resolve OpenMP directive clauses and check various requirements
@@ -12977,18 +13093,59 @@ gfc_resolve_omp_declare (gfc_namespace *ns)
}
gfc_omp_declare_variant *odv;
+ gfc_omp_namelist *range_begin = NULL;
for (odv = ns->omp_declare_variant; odv; odv = odv->next)
for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
- if (n->u.need_device_ptr
- && (!gfc_resolve_expr (n->expr) || n->sym->ts.type != BT_DERIVED
- || !n->sym->ts.u.derived->ts.is_iso_c
- || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)))
- {
- gfc_error (
- "argument list item %qs in %<need_device_ptr%> at %L must be of "
- "TYPE(C_PTR)",
- n->sym->name, &n->where);
- }
+ {
+ if ((n->expr == NULL
+ && (range_begin
+ || n->u.adj_args.range_start
+ || n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus))
+ || n->u.adj_args.error_p)
+ {
+ }
+ else if (range_begin
+ || n->u.adj_args.range_start
+ || n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ {
+ if (!n->expr
+ || !gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_CONSTANT
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->rank != 0
+ || mpz_sgn (n->expr->value.integer) < 0
+ || ((n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ && mpz_sgn (n->expr->value.integer) == 0))
+ {
+ if (n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ gfc_error ("Expected constant non-negative scalar integer "
+ "offset expression at %L", &n->where);
+ else
+ gfc_error ("For range-based %<adjust_args%>, a constant "
+ "positive scalar integer expression is required "
+ "at %L", &n->where);
+ }
+ }
+ else if (n->expr
+ && n->expr->expr_type == EXPR_CONSTANT
+ && n->expr->ts.type == BT_INTEGER
+ && mpz_sgn (n->expr->value.integer) > 0)
+ {
+ }
+ else if (!n->expr
+ || !gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_VARIABLE)
+ gfc_error ("Expected dummy parameter name or a positive integer "
+ "at %L", &n->where);
+ else if (n->expr->expr_type == EXPR_VARIABLE)
+ n->sym = n->expr->symtree->n.sym;
+
+ range_begin = n->u.adj_args.range_start ? n : NULL;
+ }
}
struct omp_udr_callback_data
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 0acf0e9adb7..7c474d288a5 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -6131,6 +6131,19 @@ create_module_nml_decl (gfc_symbol *sym)
}
}
+static void
+gfc_handle_declare_variant (gfc_symbol * sym)
+{
+ if (sym->attr.external
+ && sym->formal_ns
+ && sym->formal_ns->omp_declare_variant)
+ {
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_current_ns = sym->ns;
+ gfc_get_symbol_decl (sym);
+ gfc_current_ns = ns;
+ }
+}
/* Generate all the required code for module variables. */
@@ -6155,6 +6168,11 @@ gfc_generate_module_vars (gfc_namespace * ns)
if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
generate_coarray_init (ns);
+ /* For OpenMP, ensure that declare variant in INTERFACE is is processed
+ especially as some late diagnostic is only done on tree level. */
+ if (flag_openmp)
+ gfc_traverse_ns (ns, gfc_handle_declare_variant);
+
cur_module = NULL;
gfc_trans_use_stmts (ns);
@@ -8005,6 +8023,11 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
}
+ /* For OpenMP, ensure that declare variant in INTERFACE is is processed
+ especially as some late diagnostic is only done on tree level. */
+ if (flag_openmp)
+ gfc_traverse_ns (ns, gfc_handle_declare_variant);
+
gfc_generate_contained_functions (ns);
has_coarray_vars_or_accessors = caf_accessor_head != NULL;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 580d5837bd5..13f096324bc 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -8913,6 +8913,7 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
NULL_TREE, false))
{
tree need_device_ptr_list = NULL_TREE;
+ tree need_device_addr_list = NULL_TREE;
tree append_args_tree = NULL_TREE;
tree id = get_identifier ("omp declare variant base");
tree variant = gfc_get_symbol_decl (variant_proc_sym);
@@ -8926,13 +8927,14 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
if (ns->proc_name->ts.type == BT_CHARACTER)
arg_idx_offset++;
}
+ int nargs = 0;
+ for (gfc_formal_arglist *arg
+ = gfc_sym_get_dummy_args (ns->proc_name);
+ arg; arg = arg->next)
+ nargs++;
if (odv->append_args_list)
{
- int append_arg_no = arg_idx_offset;
- gfc_formal_arglist *arg;
- for (arg = gfc_sym_get_dummy_args (ns->proc_name); arg;
- arg = arg->next)
- append_arg_no++;
+ int append_arg_no = arg_idx_offset + nargs;
tree last_arg = NULL_TREE;
for (gfc_omp_namelist *n = odv->append_args_list;
n != NULL; n = n->next)
@@ -8965,59 +8967,191 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
else
append_args_tree = last_arg = t;
}
- /* Store as (purpose = arg number to be used for inserting
- and value = list of interop items. */
+ /* Store as 'purpose' = arg number to be used for inserting
+ and 'value' = list of interop items. */
append_args_tree = build_tree_list (
build_int_cst (integer_type_node,
append_arg_no),
append_args_tree);
}
-
- if (odv->adjust_args_list)
- need_device_ptr_list = make_node (TREE_LIST);
vec<gfc_symbol *> adjust_args_list = vNULL;
for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
arg_list != NULL; arg_list = arg_list->next)
{
- if (!arg_list->sym->attr.dummy)
+ int from, to;
+ if (arg_list->expr == NULL || arg_list->sym)
+ from = ((arg_list->u.adj_args.omp_num_args_minus
+ || arg_list->u.adj_args.omp_num_args_plus)
+ ? nargs : 1);
+ else
{
- gfc_error (
- "list item %qs at %L is not a dummy argument",
- arg_list->sym->name, &arg_list->where);
- continue;
+ if (arg_list->u.adj_args.omp_num_args_plus)
+ mpz_add_ui (arg_list->expr->value.integer,
+ arg_list->expr->value.integer, nargs);
+ if (arg_list->u.adj_args.omp_num_args_minus)
+ mpz_ui_sub (arg_list->expr->value.integer, nargs,
+ arg_list->expr->value.integer);
+ if (mpz_sgn (arg_list->expr->value.integer) <= 0)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Expected positive argument index "
+ "at %L", &arg_list->where);
+ from = 1;
+ }
+ else
+ from
+ = (mpz_fits_sint_p (arg_list->expr->value.integer)
+ ? mpz_get_si (arg_list->expr->value.integer)
+ : INT_MAX);
+ if (from > nargs)
+ gfc_warning (OPT_Wopenmp,
+ "Argument index at %L exceeds number "
+ "of arguments %d", &arg_list->where,
+ nargs);
}
- if (adjust_args_list.contains (arg_list->sym))
+ locus loc = arg_list->where;
+ if (!arg_list->u.adj_args.range_start)
+ to = from;
+ else
{
- gfc_error ("%qs at %L is specified more than once",
- arg_list->sym->name, &arg_list->where);
- continue;
+ loc = gfc_get_location_range (&arg_list->where, 0,
+ &arg_list->where, 0,
+ &arg_list->next->where);
+ if (arg_list->next->expr == NULL)
+ to = nargs;
+ else
+ {
+ if (arg_list->next->u.adj_args.omp_num_args_plus)
+ mpz_add_ui (arg_list->next->expr->value.integer,
+ arg_list->next->expr->value.integer,
+ nargs);
+ if (arg_list->next->u.adj_args.omp_num_args_minus)
+ mpz_ui_sub (arg_list->next->expr->value.integer,
+ nargs,
+ arg_list->next->expr->value.integer);
+ if (mpz_sgn (arg_list->next->expr->value.integer)
+ <= 0)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Expected positive argument "
+ "index at %L", &loc);
+ to = 0;
+ }
+ else
+ to = mpz_get_si (
+ arg_list->next->expr->value.integer);
+ }
+ if (from > to && to != 0)
+ gfc_warning (OPT_Wopenmp,
+ "Upper argument index smaller than "
+ "lower one at %L", &loc);
+ if (to > nargs)
+ to = nargs;
+ arg_list = arg_list->next;
}
- adjust_args_list.safe_push (arg_list->sym);
- if (arg_list->u.need_device_ptr)
+ if (from > nargs)
+ continue;
+ /* Change to zero based index. */
+ from--; to--;
+ gfc_formal_arglist *arg = ns->proc_name->formal;
+ if (!arg_list->sym && to >= from)
+ for (int idx = 0; idx < from; idx++)
+ arg = arg->next;
+ for (int idx = from; idx <= to; idx++)
{
- int idx;
- gfc_formal_arglist *arg;
- for (arg = ns->proc_name->formal, idx = 0;
- arg != NULL; arg = arg->next, idx++)
- 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 + arg_idx_offset)));
+ if (idx > from)
+ arg = arg->next;
+ if (arg_list->sym)
+ {
+ for (arg = ns->proc_name->formal, idx = 0;
+ arg != NULL; arg = arg->next, idx++)
+ if (arg->sym == arg_list->sym)
+ break;
+ if (!arg || !arg_list->sym->attr.dummy)
+ {
+ gfc_error ("List item %qs at %L, declared at "
+ "%L, is not a dummy argument",
+ arg_list->sym->name, &loc,
+ &arg_list->sym->declared_at);
+ continue;
+ }
+ }
+ if (arg_list->u.adj_args.need_ptr
+ && (arg->sym->ts.f90_type != BT_VOID
+ || !arg->sym->ts.u.derived->ts.is_iso_c
+ || (arg->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)
+ || arg->sym->attr.dimension))
+ {
+ gfc_error ("Argument %qs at %L to list item in "
+ "%<need_device_ptr%> at %L must be a "
+ "scalar of TYPE(C_PTR)",
+ arg->sym->name,
+ &arg->sym->declared_at, &loc);
+ if (!arg->sym->attr.value)
+ inform (gfc_get_location (&loc),
+ "Consider using %<need_device_addr%> "
+ "instead");
+ continue;
+ }
+ if (arg_list->u.adj_args.need_addr
+ && arg->sym->attr.value)
+ {
+ gfc_error ("Argument %qs at %L to list item in "
+ "%<need_device_addr%> at %L must not "
+ "have the VALUE attribute",
+ arg->sym->name,
+ &arg->sym->declared_at, &loc);
+ continue;
+ }
+ if (adjust_args_list.contains (arg->sym))
+ {
+ gfc_error ("%qs at %L is specified more than "
+ "once", arg->sym->name, &loc);
+ continue;
+ }
+ adjust_args_list.safe_push (arg->sym);
+
+ if (arg_list->u.adj_args.need_addr)
+ {
+ /* TODO: Has to to support OPTIONAL and array
+ descriptors; should check for CLASS, coarrays?
+ Reject "abc" and 123 as actual arguments (in
+ gimplify.cc or in the FE? Reject noncontiguous
+ actuals? Cf. also PR C++/118859.
+ Also check array-valued type(c_ptr). */
+ static bool warned = false;
+ if (!warned)
+ sorry_at (gfc_get_location (&loc),
+ "%<need_device_addr%> not yet "
+ "supported");
+ warned = true;
+ continue;
+ }
+ if (arg_list->u.adj_args.need_ptr
+ || arg_list->u.adj_args.need_addr)
+ {
+ // Store 0-based argument index,
+ // as in gimplify_call_expr
+ tree t
+ = build_tree_list (
+ NULL_TREE,
+ build_int_cst (integer_type_node,
+ idx + arg_idx_offset));
+ if (arg_list->u.adj_args.need_ptr)
+ need_device_ptr_list
+ = chainon (need_device_ptr_list, t);
+ else
+ need_device_addr_list
+ = chainon (need_device_addr_list, t);
+ }
}
}
tree t = NULL_TREE;
- if (need_device_ptr_list || append_args_tree)
+ if (odv->adjust_args_list || append_args_tree)
{
t = build_tree_list (need_device_ptr_list,
- NULL_TREE /*need_device_addr */),
+ need_device_addr_list),
TREE_CHAIN (t) = append_args_tree;
DECL_ATTRIBUTES (variant) = tree_cons (
get_identifier ("omp declare variant variant args"), t,
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
index c0c06e7f8fd..39824c29701 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
@@ -21,7 +21,7 @@ module main
integer function f3 (a)
import c_ptr
type(c_ptr), intent(inout) :: a
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing', 'need_device_ptr' or 'need_device_addr' at .1." }
end function
integer function f4 (a)
import c_ptr
@@ -30,15 +30,15 @@ module main
end function
integer function f5 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing', 'need_device_ptr' or 'need_device_addr' at .1." }
end function
integer function f6 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected argument list at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected ':' at .1." }
end function
integer function f7 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected argument list at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected dummy parameter name, 'omp_num_args' or constant positive integer at .1." }
end function
end interface
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-11.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-11.f90
index d2eb7c1d72c..6586abc661c 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-11.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-11.f90
@@ -18,13 +18,13 @@ module main
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f), match (construct={dispatch}) , &
!$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c)
end function
@@ -43,3 +43,76 @@ subroutine test
end subroutine
end module
+
+module other
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function g(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function g0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (g), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end module
+
+subroutine foobar
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function h(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function h0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (h), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end
+
+
+subroutine outer
+contains
+subroutine inner
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function st(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function st0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (st), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end subroutine inner
+end subroutine outer
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-13.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-13.f90
new file mode 100644
index 00000000000..319a0076d1c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-13.f90
@@ -0,0 +1,18 @@
+! This failed with a bogus:
+! 'must be of TYPE(C_PTR)'
+module m
+ implicit none
+contains
+ subroutine q()
+ end
+ subroutine one(x)
+ integer :: x
+ end
+ subroutine two(x)
+ !$omp declare variant(one) match(construct={dispatch}) adjust_args(nothing: x)
+ integer :: x
+
+ !$omp dispatch
+ call q
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-14.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-14.f90
new file mode 100644
index 00000000000..e644fd7060e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-14.f90
@@ -0,0 +1,85 @@
+module m
+ implicit none
+contains
+ subroutine f(x,y,z)
+ integer:: x, y, z
+ value :: y
+ end subroutine
+ subroutine f0(x,y,z)
+ !$omp declare variant(f) adjust_args ( need_device_addr : : omp_num_args-1) &
+ !$omp& adjust_args ( need_device_ptr : z) &
+ !$omp& match ( construct = { dispatch } )
+ integer:: x, y, z
+ value :: y
+
+! { dg-error "19: Argument 'y' at .1. to list item in 'need_device_addr' at .2. must not have the VALUE attribute" "" { target *-*-* } 8 }
+! { dg-error "62: Argument 'y' at .1. to list item in 'need_device_addr' at .2. must not have the VALUE attribute" "" { target *-*-* } 9 }
+! { dg-message "sorry, unimplemented: 'need_device_addr' not yet supported" "" { target *-*-* } 9 }
+
+! { dg-error "Argument 'z' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" "" { target *-*-* } 8 }
+! { dg-error "Argument 'z' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" "" { target *-*-* } 10 }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } 10 }
+ end subroutine
+end module m
+
+module m2
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_ptr : : ) &
+ !$omp& adjust_args ( nothing : 2, 4) &
+ !$omp& match ( construct = { dispatch } )
+
+! { dg-error "54: 'y' at .1. is specified more than once" "" { target *-*-* } 37 }
+! { dg-warning "57: Argument index at .1. exceeds number of arguments 3 \\\[-Wopenmp\\\]" "" { target *-*-* } 37 }
+ end subroutine
+ end interface
+end module m2
+
+module m3
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : omp_num_args -4 :, 3 : 2) &
+ !$omp& match ( construct = { dispatch } )
+! { dg-warning "63: Expected positive argument index at .1. \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "82: Upper argument index smaller than lower one at .1. \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+ end subroutine
+ end interface
+end module m3
+
+module m4
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : x, y, omp_num_args -2 : omp_num_args -1) &
+ !$omp& adjust_args ( need_device_addr : z) &
+ !$omp& adjust_args ( need_device_addr : omp_num_args : 3) &
+ !$omp& match ( construct = { dispatch } )
+! { dg-error "69: 'x' at .1. is specified more than once" "" { target *-*-* } .-4 }
+! { dg-error "69: 'y' at .1. is specified more than once" "" { target *-*-* } .-5 }
+! { dg-error "63: 'z' at .1. is specified more than once" "" { target *-*-* } .-4 }
+ end subroutine
+ end interface
+end module m4
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-15.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-15.f90
new file mode 100644
index 00000000000..d1001c18318
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-15.f90
@@ -0,0 +1,35 @@
+module m3
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : -1 : omp_num_args + 10 ) & ! { dg-error "64: For range-based 'adjust_args', a constant positive scalar integer expression is required" }
+ !$omp& adjust_args ( nothing : 1+1) & ! { dg-error "expected ':'" }
+ !$omp& match ( construct = { dispatch } )
+ end subroutine
+ end interface
+end module m3
+
+module m4
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : 3.3 ) & ! { dg-error "Expected dummy parameter name or a positive integer" }
+ !$omp& adjust_args ( nothing : 1 : y ) & ! { dg-error "For range-based 'adjust_args', a constant positive scalar integer expression is required" }
+ !$omp& match ( construct = { dispatch } )
+ end subroutine
+ end interface
+end module m4
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
index c65a4839ca5..35acf82a7fe 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
@@ -12,7 +12,8 @@ contains
subroutine f3 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" }
+! { dg-error "Expected dummy parameter name or a positive integer at .1." "" { target *-*-* } .-1 }
end subroutine
end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
index 9a32d2b7d92..d4244ce14e6 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2a.f90
@@ -15,13 +15,13 @@ module main
end interface
contains
- subroutine f9 (i)
+ subroutine f9 (i) ! { dg-error "Argument 'i' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: i) ! { dg-error "argument list item 'i' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: i) ! { dg-error "Argument 'i' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
end subroutine
- subroutine f13 (a)
+ subroutine f13 (a) ! { dg-error "Argument 'a' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
type(c_funptr), intent(inout) :: a
- !$omp declare variant (h) match (construct={dispatch}) adjust_args (need_device_ptr: a) ! { dg-error "argument list item 'a' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." }
+ !$omp declare variant (h) match (construct={dispatch}) adjust_args (need_device_ptr: a) ! { dg-error "Argument 'a' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
end subroutine
subroutine test
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
index 9033221cc5c..4ad64c22d6f 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
@@ -4,7 +4,7 @@
module main
use iso_c_binding, only: c_ptr
implicit none
- type(c_ptr) :: b
+ type(c_ptr) :: b ! { dg-error "List item 'b' at .1., declared at .2., is not a dummy argument" }
contains
subroutine base2 (a)
@@ -17,7 +17,7 @@ contains
end subroutine
subroutine base4 (a)
type(c_ptr), intent(inout) :: a
- !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: b) ! { dg-error "list item 'b' at .1. is not a dummy argument" }
+ !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: b) ! { dg-error "List item 'b' at .1., declared at .2., is not a dummy argument" }
end subroutine
subroutine variant2 (a)
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
index 2f44c0026db..7452e12ff0c 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
@@ -15,13 +15,13 @@ module main
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c)
end function
@@ -29,7 +29,7 @@ module main
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c)
end function
@@ -54,5 +54,5 @@ end subroutine
end module
! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } }
-! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(c, D\.\[0-9]+\\);" 2 "gimple" } }
! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
index 2f44c0026db..7452e12ff0c 100644
--- a/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
@@ -15,13 +15,13 @@ module main
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c)
end function
@@ -29,7 +29,7 @@ module main
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c)
end function
@@ -54,5 +54,5 @@ end subroutine
end module
! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } }
-! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(c, D\.\[0-9]+\\);" 2 "gimple" } }
! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
new file mode 100644
index 00000000000..da53c1f1fa3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
@@ -0,0 +1,20 @@
+! { dg-additional-options "-fdump-tree-gimple" }
+! { dg-final { scan-tree-dump-not "g \\(\\)" "gimple" } }
+! { dg-final { scan-tree-dump "i = f \\(\\);" "gimple" } }
+
+! PR fortran/115271
+
+module m
+interface
+ integer function f ()
+ end
+ integer function g ()
+ !$omp declare variant(f) match(construct={dispatch})
+ end
+end interface
+end
+
+use m
+!$omp dispatch
+ i = g()
+end
