https://gcc.gnu.org/g:e0246616020e95e74afa9d504c8848e6e905fab4
commit e0246616020e95e74afa9d504c8848e6e905fab4
Author: Tobias Burnus <tbur...@baylibre.com>
Date: Mon Feb 17 22:52:34 2025 +0100
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_omp_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.
(cherry picked from commit 8268c8256dd430174e89142be9ee77b036d6310d)
Diff:
---
gcc/fortran/ChangeLog.omp | 17 ++
gcc/fortran/gfortran.h | 10 +-
gcc/fortran/openmp.cc | 243 +++++++++++++++++----
gcc/fortran/trans-decl.cc | 23 ++
gcc/fortran/trans-openmp.cc | 212 ++++++++++++++----
gcc/testsuite/ChangeLog.omp | 19 ++
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 ++
17 files changed, 692 insertions(+), 106 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 56c8ee2b2fc0..f0a2a48f7cf7 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,20 @@
+2025-02-18 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2025-02-17 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/115271
+ * 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_omp_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.
+
2025-02-12 Tobias Burnus <tbur...@baylibre.com>
Backported from master:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5ef66173e696..40711fcec52f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1397,7 +1397,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 71f148e45c2f..16b255ec1062 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -6988,21 +6988,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
@@ -7011,13 +7011,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)
{
@@ -7036,32 +7036,156 @@ 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 = saved_loc;
+ }
+ else
+ {
+ p->where = saved_loc;
+ 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)
{
@@ -13115,18 +13239,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
@@ -13275,18 +13387,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 7e88ecc42fcb..7bd05ccc5c60 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -5991,6 +5991,19 @@ create_module_nml_decl (gfc_symbol *sym)
}
}
+static void
+gfc_handle_omp_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. */
@@ -6015,6 +6028,11 @@ gfc_generate_module_vars (gfc_namespace * ns)
if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
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_omp_declare_variant);
+
cur_module = NULL;
gfc_trans_use_stmts (ns);
@@ -7870,6 +7888,11 @@ gfc_generate_function_code (gfc_namespace * ns)
saved_parent_function_decls = dm_saved_parent_function_decls;
}
+ /* 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_omp_declare_variant);
+
gfc_generate_contained_functions (ns);
has_coarray_vars = false;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 09d237617b44..3292f0b2c7bf 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -11459,6 +11459,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);
@@ -11472,13 +11473,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)
@@ -11511,59 +11513,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 = 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 (need_device_ptr_list
+ || need_device_addr_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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 6a13a2810636..c9548f594caa 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,22 @@
+2025-02-18 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2025-02-17 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/115271
+ * 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.
+
2025-02-12 Tobias Burnus <tbur...@baylibre.com>
Backported from master:
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
index c0c06e7f8fdf..39824c297019 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 d2eb7c1d72cc..6586abc661c3 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 000000000000..319a0076d1c9
--- /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 000000000000..313e4e65f9f2
--- /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 "64: 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 "62: Expected positive argument index at .1. \\\[-Wopenmp\\\]"
"" { target *-*-* } .-2 }
+! { dg-warning "86: 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 "86: 'x' at .1. is specified more than once" "" { target *-*-* }
.-4 }
+! { dg-error "86: 'y' at .1. is specified more than once" "" { target *-*-* }
.-5 }
+! { dg-error "78: '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 000000000000..d1001c183184
--- /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 c65a4839ca5d..35acf82a7fe9 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 9a32d2b7d92f..d4244ce14e62 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 9033221cc5c2..4ad64c22d6fa 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 2f44c0026dbf..7452e12ff0cd 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 2f44c0026dbf..7452e12ff0cd 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 000000000000..da53c1f1fa36
--- /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
