This patch adds support for the `dispatch` construct and the `adjust_args`
clause to the Fortran front-end.
Handling of `adjust_args` across translation units is missing due to PR115271.
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_clauses): Handle novariants and nocontext
clauses.
(show_omp_node): Handle EXEC_OMP_DISPATCH.
(show_code_node): Likewise.
* frontend-passes.cc (gfc_code_walker): Handle novariants and nocontext.
* gfortran.h (enum gfc_statement): Add ST_OMP_DISPATCH.
(symbol_attribute): Add omp_declare_variant_need_device_ptr.
(gfc_omp_clauses): Add novariants and nocontext.
(gfc_omp_declare_variant): Add need_device_ptr_arg_list.
(enum gfc_exec_op): Add EXEC_OMP_DISPATCH.
* match.h (gfc_match_omp_dispatch): Declare.
* openmp.cc (gfc_free_omp_clauses): Free novariants and nocontext
clauses.
(gfc_free_omp_declare_variant_list): Free need_device_ptr_arg_list
namelist.
(enum omp_mask2): Add OMP_CLAUSE_NOVARIANTS and OMP_CLAUSE_NOCONTEXT.
(gfc_match_omp_clauses): Handle OMP_CLAUSE_NOVARIANTS and
OMP_CLAUSE_NOCONTEXT.
(OMP_DISPATCH_CLAUSES): Define.
(gfc_match_omp_dispatch): New function.
(gfc_match_omp_declare_variant): Parse adjust_args.
(resolve_omp_clauses): Handle adjust_args, novariants and nocontext.
Adjust handling of OMP_LIST_IS_DEVICE_PTR.
(icode_code_error_callback): Handle EXEC_OMP_DISPATCH.
(omp_code_to_statement): Likewise.
(resolve_omp_dispatch): New function.
(gfc_resolve_omp_directive): Handle EXEC_OMP_DISPATCH.
* parse.cc (decode_omp_directive): Match dispatch.
(next_statement): Handle ST_OMP_DISPATCH.
(gfc_ascii_statement): Likewise.
(parse_omp_dispatch): New function.
(parse_executable): Handle ST_OMP_DISPATCH.
* resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_DISPATCH.
* st.cc (gfc_free_statement): Likewise.
* trans-decl.cc (create_function_arglist): Declare.
(gfc_get_extern_function_decl): Call it.
* trans-openmp.cc (gfc_trans_omp_clauses): Handle novariants and
nocontext.
(gfc_trans_omp_dispatch): New function.
(gfc_trans_omp_directive): Handle EXEC_OMP_DISPATCH.
(gfc_trans_omp_declare_variant): Handle adjust_args.
* trans.cc (trans_code): Handle EXEC_OMP_DISPATCH:.
* types.def (BT_FN_PTR_CONST_PTR_INT): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/declare-variant-2.f90: Update dg-error.
* gfortran.dg/gomp/declare-variant-21.f90: New test (xfail).
* gfortran.dg/gomp/declare-variant-21-aux.f90: New test.
* gfortran.dg/gomp/adjust-args-1.f90: New test.
* gfortran.dg/gomp/adjust-args-2.f90: New test.
* gfortran.dg/gomp/adjust-args-3.f90: New test.
* gfortran.dg/gomp/adjust-args-4.f90: New test.
* gfortran.dg/gomp/adjust-args-5.f90: New test.
* gfortran.dg/gomp/dispatch-1.f90: New test.
* gfortran.dg/gomp/dispatch-2.f90: New test.
* gfortran.dg/gomp/dispatch-3.f90: New test.
* gfortran.dg/gomp/dispatch-4.f90: New test.
* gfortran.dg/gomp/dispatch-5.f90: New test.
* gfortran.dg/gomp/dispatch-6.f90: New test.
* gfortran.dg/gomp/dispatch-7.f90: New test.
* gfortran.dg/gomp/dispatch-8.f90: New test.
---
gcc/fortran/dump-parse-tree.cc | 17 ++
gcc/fortran/frontend-passes.cc | 2 +
gcc/fortran/gfortran.h | 11 +-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.cc | 201 ++++++++++++++++--
gcc/fortran/parse.cc | 39 +++-
gcc/fortran/resolve.cc | 2 +
gcc/fortran/st.cc | 1 +
gcc/fortran/trans-decl.cc | 9 +-
gcc/fortran/trans-openmp.cc | 161 ++++++++++++++
gcc/fortran/trans.cc | 1 +
gcc/fortran/types.def | 1 +
.../gfortran.dg/gomp/adjust-args-1.f90 | 63 ++++++
.../gfortran.dg/gomp/adjust-args-2.f90 | 18 ++
.../gfortran.dg/gomp/adjust-args-3.f90 | 26 +++
.../gfortran.dg/gomp/adjust-args-4.f90 | 58 +++++
.../gfortran.dg/gomp/adjust-args-5.f90 | 58 +++++
.../gfortran.dg/gomp/declare-variant-2.f90 | 6 +-
.../gomp/declare-variant-21-aux.f90 | 18 ++
.../gfortran.dg/gomp/declare-variant-21.f90 | 28 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90 | 77 +++++++
gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90 | 79 +++++++
gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90 | 39 ++++
gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90 | 19 ++
gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90 | 24 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90 | 38 ++++
gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90 | 27 +++
gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90 | 39 ++++
28 files changed, 1042 insertions(+), 21 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 80aa8ef84e7..a15a17c086c 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2139,6 +2139,18 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
}
fputc (')', dumpfile);
}
+ if (omp_clauses->novariants)
+ {
+ fputs (" NOVARIANTS(", dumpfile);
+ show_expr (omp_clauses->novariants);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->nocontext)
+ {
+ fputs (" NOCONTEXT(", dumpfile);
+ show_expr (omp_clauses->nocontext);
+ fputc (')', dumpfile);
+ }
}
/* Show a single OpenMP or OpenACC directive node and everything underneath it
@@ -2176,6 +2188,9 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_CANCEL: name = "CANCEL"; break;
case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+ case EXEC_OMP_DISPATCH:
+ name = "DISPATCH";
+ break;
case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break;
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
name = "DISTRIBUTE PARALLEL DO"; break;
@@ -2279,6 +2294,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
@@ -3522,6 +3538,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 3c06018fdbb..1a0ef50b91d 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5669,6 +5669,8 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn,
walk_expr_fn_t exprfn,
WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
WALK_SUBEXPR (co->ext.omp_clauses->priority);
WALK_SUBEXPR (co->ext.omp_clauses->detach);
+ WALK_SUBEXPR (co->ext.omp_clauses->novariants);
+ WALK_SUBEXPR (co->ext.omp_clauses->nocontext);
for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
for (n = co->ext.omp_clauses->lists[list_types[idx]];
n; n = n->next)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ed1213a41cb..c06f69588e1 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -323,7 +323,7 @@ enum gfc_statement
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE,
ST_OMP_UNROLL, ST_OMP_END_UNROLL,
- ST_OMP_TILE, ST_OMP_END_TILE
+ ST_OMP_TILE, ST_OMP_END_TILE, ST_OMP_DISPATCH
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -1006,6 +1006,9 @@ typedef struct
ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
unsigned omp_allocate:1;
+ /* Mentioned in OMP DECLARE VARIANT. */
+ unsigned omp_declare_variant_need_device_ptr : 1;
+
/* Mentioned in OACC DECLARE. */
unsigned oacc_declare_create:1;
unsigned oacc_declare_copyin:1;
@@ -1433,6 +1436,7 @@ enum
OMP_LIST_HAS_DEVICE_ADDR,
OMP_LIST_ENTER,
OMP_LIST_USES_ALLOCATORS,
+ OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
@@ -1578,6 +1582,8 @@ typedef struct gfc_omp_clauses
struct gfc_expr *depobj;
struct gfc_expr *dist_chunk_size;
struct gfc_expr *message;
+ struct gfc_expr *novariants;
+ struct gfc_expr *nocontext;
struct gfc_omp_assumptions *assume;
struct gfc_expr_list *sizes_list;
const char *critical_name;
@@ -1707,6 +1713,7 @@ typedef struct gfc_omp_declare_variant
struct gfc_symtree *variant_proc_symtree;
gfc_omp_set_selector *set_selectors;
+ gfc_omp_namelist *need_device_ptr_arg_list;
bool checked_p : 1; /* Set if previously checked for errors. */
bool error_p : 1; /* Set if error found in directive. */
@@ -3037,7 +3044,7 @@ enum gfc_exec_op
EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
EXEC_OMP_UNROLL, EXEC_OMP_TILE,
- EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH
};
typedef struct gfc_code
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index c2b7d69c37c..31280ba15ad 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -163,6 +163,7 @@ match gfc_match_omp_declare_simd (void);
match gfc_match_omp_declare_target (void);
match gfc_match_omp_declare_variant (void);
match gfc_match_omp_depobj (void);
+match gfc_match_omp_dispatch (void);
match gfc_match_omp_distribute (void);
match gfc_match_omp_distribute_parallel_do (void);
match gfc_match_omp_distribute_parallel_do_simd (void);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 333f0c7fe7f..c7a89924b78 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -72,7 +72,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = {
{"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
{"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
{"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
- /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
+ {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH},
{"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
{"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
/* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
@@ -181,6 +181,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_expr (c->num_tasks);
gfc_free_expr (c->priority);
gfc_free_expr (c->detach);
+ gfc_free_expr (c->novariants);
+ gfc_free_expr (c->nocontext);
gfc_free_expr (c->async_expr);
gfc_free_expr (c->gang_num_expr);
gfc_free_expr (c->gang_static_expr);
@@ -323,6 +325,8 @@ gfc_free_omp_declare_variant_list (gfc_omp_declare_variant
*list)
gfc_omp_declare_variant *current = list;
list = list->next;
gfc_free_omp_set_selector_list (current->set_selectors);
+ gfc_free_omp_namelist (current->need_device_ptr_arg_list, false, false,
+ false);
free (current);
}
}
@@ -1106,6 +1110,8 @@ enum omp_mask2
OMP_CLAUSE_FULL, /* OpenMP 5.1. */
OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
+ OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
+ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
/* This must come last. */
OMP_MASK2_LAST
};
@@ -3231,6 +3237,25 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const
omp_mask mask,
c->assume->no_parallelism = needs_space = true;
continue;
}
+
+ if ((mask & OMP_CLAUSE_NOVARIANTS)
+ && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
+ &c->novariants))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOCONTEXT)
+ && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
+ &c->nocontext))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
if ((mask & OMP_CLAUSE_NOGROUP)
&& (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
!= MATCH_NO)
@@ -4590,6 +4615,9 @@ cleanup:
(omp_mask (OMP_CLAUSE_SIZES))
#define OMP_ALLOCATORS_CLAUSES \
omp_mask (OMP_CLAUSE_ALLOCATE)
+#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)
static match
@@ -4903,6 +4931,12 @@ error:
return MATCH_ERROR;
}
+match
+gfc_match_omp_dispatch (void)
+{
+ return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
+}
+
match
gfc_match_omp_distribute (void)
{
@@ -6129,6 +6163,7 @@ gfc_match_omp_declare_variant (void)
odv = gfc_get_omp_declare_variant ();
odv->where = gfc_current_locus;
odv->variant_proc_symtree = variant_proc_st;
+ odv->need_device_ptr_arg_list = NULL;
odv->base_proc_symtree = base_proc_st;
odv->next = NULL;
odv->error_p = false;
@@ -6145,13 +6180,29 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
+ bool has_match = false, has_adjust_args = false;
+ locus adjust_args_loc;
+
for (;;)
{
- if (gfc_match (" match") != MATCH_YES)
+ enum clause
+ {
+ match,
+ adjust_args
+ } ccode;
+
+ if (gfc_match (" match") == MATCH_YES)
+ ccode = match;
+ else if (gfc_match (" adjust_args") == MATCH_YES)
+ {
+ ccode = adjust_args;
+ adjust_args_loc = gfc_current_locus;
+ }
+ else
{
if (first_p)
{
- gfc_error ("expected %<match%> at %C");
+ gfc_error ("expected %<match%> or %<adjust_args%> at %C");
return MATCH_ERROR;
}
else
@@ -6164,18 +6215,88 @@ gfc_match_omp_declare_variant (void)
return MATCH_ERROR;
}
- if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
- return MATCH_ERROR;
-
- if (gfc_match (" )") != MATCH_YES)
+ if (ccode == match)
{
- gfc_error ("expected %<)%> at %C");
- return MATCH_ERROR;
+ has_match = true;
+ if (gfc_match_omp_context_selector_specification (odv)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (ccode == 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)
+ need_device_ptr_p = true;
+ else
+ {
+ gfc_error ("expected %<nothing%> or %<need_device_ptr%> at %C");
+ return MATCH_ERROR;
+ }
+ if (need_device_ptr_p)
+ {
+ if (gfc_match_omp_variable_list (" :",
+ &odv->need_device_ptr_arg_list,
+ false)
+ != MATCH_YES)
+ {
+ gfc_error ("expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ for (gfc_omp_namelist *n = odv->need_device_ptr_arg_list;
+ n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.dummy)
+ {
+ gfc_error ("list item %qs at %L is not a dummy argument",
+ n->sym->name, &n->where);
+ return MATCH_ERROR;
+ }
+ 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);
+ return MATCH_ERROR;
+ }
+ }
+ }
+ else
+ {
+ gfc_omp_namelist *nothing_arg_list = NULL;
+ if (gfc_match_omp_variable_list (" :", ¬hing_arg_list, false)
+ != MATCH_YES)
+ {
+ gfc_error ("expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ gfc_free_omp_namelist (nothing_arg_list, false, false, false);
+ }
}
first_p = false;
}
+ if (has_adjust_args && !has_match)
+ {
+ gfc_error ("an %<adjust_args%> clause at %L can only be specified if the
"
+ "%<dispatch%> selector of the construct selector set appears "
+ "in the %<match%> clause",
+ &adjust_args_loc);
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
@@ -7618,7 +7739,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" };
+ "USES_ALLOCATORS", "ADJUST_ARGS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
@@ -7800,6 +7921,26 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
&expr->where);
}
+ if (omp_clauses->novariants)
+ {
+ gfc_expr *expr = omp_clauses->novariants;
+ if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
+ || expr->rank != 0)
+ gfc_error (
+ "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
+ if (omp_clauses->nocontext)
+ {
+ gfc_expr *expr = omp_clauses->nocontext;
+ if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
+ || expr->rank != 0)
+ gfc_error (
+ "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
+ &expr->where);
+ if_without_mod = true;
+ }
if (omp_clauses->num_threads)
resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
if (omp_clauses->chunk_size)
@@ -8749,14 +8890,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
last = NULL;
for (n = omp_clauses->lists[list]; n != NULL; )
{
- if (n->sym->ts.type == BT_DERIVED
- && n->sym->ts.u.derived->ts.is_iso_c
- && code->op != EXEC_OMP_TARGET)
+ 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))
+ && code->op == EXEC_OMP_DISPATCH)
/* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
gfc_error ("List item %qs in %s clause at %L must be of "
"TYPE(C_PTR)", n->sym->name, name, &n->where);
else if (n->sym->ts.type != BT_DERIVED
- || !n->sym->ts.u.derived->ts.is_iso_c)
+ || !n->sym->ts.u.derived->ts.is_iso_c
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR))
{
/* For TARGET, non-C_PTR are deprecated and handled as
has_device_addr. */
@@ -10391,6 +10536,7 @@ icode_code_error_callback (gfc_code **codep,
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
case EXEC_OMP_SCOPE:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_DISPATCH:
gfc_error ("%s cannot contain OpenMP directive in intervening code "
"at %L",
state->name, &code->loc);
@@ -11365,6 +11511,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_TILE;
case EXEC_OMP_UNROLL:
return ST_OMP_UNROLL;
+ case EXEC_OMP_DISPATCH:
+ return ST_OMP_DISPATCH;
default:
gcc_unreachable ();
}
@@ -11780,6 +11928,26 @@ resolve_omp_target (gfc_code *code)
#undef GFC_IS_TEAMS_CONSTRUCT
}
+static void
+resolve_omp_dispatch (gfc_code *code)
+{
+ gfc_code *next = code->block->next;
+ if (next == NULL)
+ return;
+ gfc_exec_op op = next->op;
+ if (op != EXEC_CALL
+ && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
+ gfc_error (
+ "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
+ "call with optional assignment",
+ &code->loc);
+
+ if ((op == EXEC_CALL && next->resolved_sym->attr.proc_pointer)
+ || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
+ gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
+ "procedure pointer",
+ &code->loc);
+}
/* Resolve OpenMP directive clauses and check various requirements
of each directive. */
@@ -11895,6 +12063,11 @@ gfc_resolve_omp_directive (gfc_code *code,
gfc_namespace *ns)
code->ext.omp_clauses->if_present = false;
resolve_omp_clauses (code, code->ext.omp_clauses, ns);
break;
+ case EXEC_OMP_DISPATCH:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, code->ext.omp_clauses, ns);
+ resolve_omp_dispatch (code);
+ break;
default:
break;
}
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index b28c8a94547..67e1157be93 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -1058,6 +1058,7 @@ decode_omp_directive (void)
break;
case 'd':
matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
+ matcho ("dispatch", gfc_match_omp_dispatch, ST_OMP_DISPATCH);
matchs ("distribute parallel do simd",
gfc_match_omp_distribute_parallel_do_simd,
ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
@@ -1924,7 +1925,7 @@ next_statement (void)
case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
- case ST_OMP_TILE: case ST_OMP_UNROLL: \
+ case ST_OMP_TILE: case ST_OMP_UNROLL: case ST_OMP_DISPATCH: \
case ST_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@@ -2606,6 +2607,9 @@ gfc_ascii_statement (gfc_statement st, bool
strip_sentinel)
case ST_OMP_DEPOBJ:
p = "!$OMP DEPOBJ";
break;
+ case ST_OMP_DISPATCH:
+ p = "!$OMP DISPATCH";
+ break;
case ST_OMP_DISTRIBUTE:
p = "!$OMP DISTRIBUTE";
break;
@@ -6214,6 +6218,35 @@ parse_omp_structured_block (gfc_statement omp_st, bool
workshare_stmts_only)
}
+static gfc_statement
+parse_omp_dispatch (void)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (ST_OMP_DISPATCH);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ st = next_statement ();
+ if (st == ST_CALL || st == ST_ASSIGNMENT)
+ accept_statement (st);
+ else
+ {
+ gfc_error ("%<OMP DISPATCH%> directive must be followed by a procedure "
+ "call with optional assignment at %C");
+ reject_statement ();
+ }
+ pop_state ();
+ st = next_statement ();
+ return st;
+}
+
/* Accept a series of executable statements. We return the first
statement that doesn't fit to the caller. Any block statements are
passed on to the correct handler, which usually passes the buck
@@ -6416,6 +6449,10 @@ parse_executable (gfc_statement st)
st = parse_omp_oacc_atomic (true);
continue;
+ case ST_OMP_DISPATCH:
+ st = parse_omp_dispatch ();
+ continue;
+
default:
return st;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4f4fafa4217..3ad44b0dde7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11378,6 +11378,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
@@ -13058,6 +13059,7 @@ start:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 0218d290782..3d0a40a4b41 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -222,6 +222,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 54ab60b4935..ad9fedc3452 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2156,6 +2156,8 @@ get_proc_pointer_decl (gfc_symbol *sym)
return decl;
}
+static void
+create_function_arglist (gfc_symbol *sym);
/* Get a basic decl for an external function. */
@@ -2409,7 +2411,12 @@ module_sym:
if (sym->formal_ns->omp_declare_simd)
gfc_trans_omp_declare_simd (sym->formal_ns);
if (flag_openmp)
- gfc_trans_omp_declare_variant (sym->formal_ns);
+ {
+ // We need DECL_ARGUMENTS to put attributes on, in case some arguments
+ // need adjustment
+ create_function_arglist (sym->formal_ns->proc_name);
+ gfc_trans_omp_declare_variant (sym->formal_ns);
+ }
}
return fndecl;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index df1bf144e23..a4d32811663 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -4233,6 +4233,36 @@ gfc_trans_omp_clauses (stmtblock_t *block,
gfc_omp_clauses *clauses,
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
+ if (clauses->novariants)
+ {
+ tree novariants_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->novariants);
+ gfc_add_block_to_block (block, &se.pre);
+ novariants_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
+ OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->nocontext)
+ {
+ tree nocontext_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->nocontext);
+ gfc_add_block_to_block (block, &se.pre);
+ nocontext_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
+ OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
if (clauses->num_threads)
{
tree num_threads;
@@ -6360,6 +6390,30 @@ gfc_trans_omp_depobj (gfc_code *code)
return gfc_finish_block (&block);
}
+static tree
+gfc_trans_omp_dispatch (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_code *next = code->block->next;
+ // assume ill-formed "function dispatch structured
+ // block" have already been rejected by resolve_omp_dispatch
+ gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
+
+ tree body = gfc_trans_code (next);
+ gfc_start_block (&block);
+ tree omp_clauses
+ = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
+
+ tree stmt = make_node (OMP_DISPATCH);
+ SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
+ TREE_TYPE (stmt) = void_type_node;
+ OMP_DISPATCH_BODY (stmt) = body;
+ OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
+
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
static tree
gfc_trans_omp_error (gfc_code *code)
{
@@ -8272,6 +8326,8 @@ gfc_trans_omp_directive (gfc_code *code)
case EXEC_OMP_UNROLL:
return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
NULL);
+ case EXEC_OMP_DISPATCH:
+ return gfc_trans_omp_dispatch (code);
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_DISTRIBUTE_SIMD:
@@ -8388,6 +8444,7 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
tree base_fn_decl = ns->proc_name->backend_decl;
gfc_namespace *search_ns = ns;
gfc_omp_declare_variant *next;
+ vec<tree> adjust_args_list = vNULL;
for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
search_ns; odv = next)
@@ -8583,6 +8640,19 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
variant_proc_sym = NULL;
}
}
+ if (odv->need_device_ptr_arg_list != NULL
+ && omp_get_context_selector (set_selectors,
OMP_TRAIT_SET_CONSTRUCT,
+ OMP_TRAIT_CONSTRUCT_DISPATCH)
+ == NULL_TREE)
+ {
+ gfc_error ("an %<adjust_args%> clause can only be "
+ "specified if the "
+ "%<dispatch%> selector of the construct "
+ "selector set appears "
+ "in the %<match%> clause at %L",
+ &odv->where);
+ variant_proc_sym = NULL;
+ }
if (variant_proc_sym != NULL)
{
gfc_set_sym_referenced (variant_proc_sym);
@@ -8599,6 +8669,97 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
DECL_ATTRIBUTES (base_fn_decl)
= tree_cons (id, build_tree_list (variant, set_selectors),
DECL_ATTRIBUTES (base_fn_decl));
+
+ // Handle adjust_args
+ for (gfc_omp_namelist *arg_list
+ = odv->need_device_ptr_arg_list;
+ arg_list != NULL; arg_list = arg_list->next)
+ {
+ if (arg_list->sym->backend_decl == NULL_TREE)
+ {
+ gfc_error (
+ "%s at %L is not a base function argument",
+ arg_list->sym->name, &arg_list->where);
+ continue;
+ }
+
+ tree base_fn_arg_decl = arg_list->sym->backend_decl;
+ if (base_fn_arg_decl != error_mark_node)
+ {
+ // Is t specified more than once?
+ if (adjust_args_list.contains (base_fn_arg_decl))
+ {
+ gfc_error (
+ "%qD at %L is specified more than once",
+ base_fn_arg_decl, &arg_list->where);
+ continue;
+ }
+ adjust_args_list.safe_push (base_fn_arg_decl);
+
+ // Handle variant argument
+ tree variant
+ = gfc_get_symbol_decl (variant_proc_sym);
+ tree variant_parm = DECL_ARGUMENTS (variant);
+ int idx;
+ tree arg;
+ for (arg = DECL_ARGUMENTS (base_fn_decl), idx = 0;
+ arg != NULL; arg = TREE_CHAIN (arg), idx++)
+ if (arg == base_fn_arg_decl)
+ break;
+ gcc_assert (arg != NULL_TREE);
+ if (variant_parm == NULL_TREE)
+ {
+ gfc_formal_arglist *arg
+ = variant_proc_sym->formal;
+ for (int i = 0; i < idx; i++)
+ {
+ arg = arg->next;
+ gcc_assert (arg != NULL);
+ }
+
+ // Check we got the right parameter name
+ if (strcmp (arg_list->sym->name, arg->sym->name)
+ != 0)
+ {
+ gfc_error ("%s at %L is not a variant "
+ "function argument",
+ arg_list->sym->name,
+ &arg_list->where);
+ continue;
+ }
+ arg->sym->attr
+ .omp_declare_variant_need_device_ptr
+ = 1;
+ }
+ else
+ {
+ for (int i = 0; i < idx; i++)
+ {
+ variant_parm = TREE_CHAIN (variant_parm);
+ gcc_assert (variant_parm != NULL_TREE);
+ }
+ // Check we got the right parameter name
+ if (strcmp (arg_list->sym->name,
+ IDENTIFIER_POINTER (
+ DECL_NAME (variant_parm)))
+ != 0)
+ {
+ gfc_error ("%s at %L is not a variant "
+ "function argument",
+ arg_list->sym->name,
+ &arg_list->where);
+ continue;
+ }
+
+ tree attr = tree_cons (
+ get_identifier (
+ "omp declare variant adjust_args "
+ "need_device_ptr"),
+ NULL_TREE, DECL_ATTRIBUTES (variant_parm));
+ DECL_ATTRIBUTES (variant_parm) = attr;
+ }
+ }
+ }
}
}
}
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 1067e032621..882d205b183 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2597,6 +2597,7 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_DISPATCH:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def
index 390cc9542f7..5047c8f816a 100644
--- a/gcc/fortran/types.def
+++ b/gcc/fortran/types.def
@@ -120,6 +120,7 @@ DEF_FUNCTION_TYPE_2 (BT_FN_BOOL_INT_BOOL, BT_BOOL, BT_INT,
BT_BOOL)
DEF_FUNCTION_TYPE_2 (BT_FN_VOID_PTR_PTRMODE,
BT_VOID, BT_PTR, BT_PTRMODE)
DEF_FUNCTION_TYPE_2 (BT_FN_VOID_CONST_PTR_SIZE, BT_VOID, BT_CONST_PTR, BT_SIZE)
+DEF_FUNCTION_TYPE_2 (BT_FN_PTR_CONST_PTR_INT, BT_PTR, BT_CONST_PTR, BT_INT)
DEF_POINTER_TYPE (BT_PTR_FN_VOID_PTR_PTR, BT_FN_VOID_PTR_PTR)
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
new file mode 100644
index 00000000000..68adb60a397
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-1.f90
@@ -0,0 +1,63 @@
+! Test parsing of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ use iso_c_binding, only: c_ptr, c_funptr
+ implicit none
+ integer :: b
+ interface
+ integer function f0 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ end function
+ integer function g (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ end function
+ integer function h (a)
+ import c_funptr
+ type(c_funptr), intent(inout) :: a
+ end function
+ integer function f1 (i)
+ integer, intent(in) :: i
+ end function
+
+ 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." }
+ end function
+ integer function f4 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (f0) adjust_args (nothing: a) ! { dg-error "an
'adjust_args' clause at .1. can only be specified if the 'dispatch' selector of
the construct selector set appears in the 'match' clause" }
+ 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." }
+ 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." }
+ 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." }
+ end function
+ integer function f9 (i)
+ 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." }
+ end function
+ integer function f12 (a)
+ import c_ptr
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (g) match (construct={dispatch}) adjust_args
(need_device_ptr: b) ! { dg-error "list item 'b' at .1. is not a dummy
argument" }
+ end function
+ integer function f13 (a)
+ import c_funptr
+ 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." }
+ end function
+
+ end interface
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
new file mode 100644
index 00000000000..c65a4839ca5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-2.f90
@@ -0,0 +1,18 @@
+! Test resolution of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ implicit none
+interface
+subroutine f1 (i)
+ integer, intent(inout) :: i
+end subroutine
+end interface
+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" }
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
new file mode 100644
index 00000000000..b731cb340c1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-3.f90
@@ -0,0 +1,26 @@
+! Test translation of OMP clause adjust_args
+! { dg-do compile }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ !type(c_ptr) :: a
+
+contains
+ subroutine base2 (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (variant2) match (construct={parallel}) adjust_args
(need_device_ptr: a) ! { dg-error "an 'adjust_args' clause can only be
specified if the 'dispatch' selector of the construct selector set appears in
the 'match' clause at .1." }
+ end subroutine
+ subroutine base3 (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (variant2) match (construct={dispatch}) adjust_args
(need_device_ptr: a) adjust_args (need_device_ptr: a) ! { dg-error "'a' at .1.
is specified more than once" }
+ end subroutine
+
+ subroutine variant2 (a)
+ type(c_ptr), intent(inout) :: a
+ end subroutine
+ subroutine variant3 (i)
+ integer :: i
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
new file mode 100644
index 00000000000..75e884044b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-4.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+
+ interface
+ integer function f(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 f0(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ 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
+ integer function f1(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ 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
+ end interface
+
+contains
+subroutine test
+ integer :: a
+ type(c_ptr) :: b
+ type(c_ptr) :: c(2)
+ type(struct) :: s
+
+ s%a = f0 (a, b, c)
+ !$omp dispatch
+ s%a = f0 (a, b, c)
+
+ s%b = f1 (a, b, c)
+ !$omp dispatch
+ s%b = f1 (a, b, c)
+
+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
\\(&b, 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
new file mode 100644
index 00000000000..75e884044b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-5.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+
+ interface
+ integer function f(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 f0(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ 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
+ integer function f1(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ 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
+ end interface
+
+contains
+subroutine test
+ integer :: a
+ type(c_ptr) :: b
+ type(c_ptr) :: c(2)
+ type(struct) :: s
+
+ s%a = f0 (a, b, c)
+ !$omp dispatch
+ s%a = f0 (a, b, c)
+
+ s%b = f1 (a, b, c)
+ !$omp dispatch
+ s%b = f1 (a, b, c)
+
+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
\\(&b, D\.\[0-9]+\\);" 2 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
index 7fc5071feff..62d2cb96fac 100644
--- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
@@ -18,10 +18,10 @@ contains
!$omp declare variant match(user={condition(.false.)}) ! { dg-error
"expected '\\(' at .1." }
end subroutine
subroutine f6 ()
- !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." }
+ !$omp declare variant (f1) ! { dg-error "expected 'match' or 'adjust_args'
at .1." }
end subroutine
subroutine f7 ()
- !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." }
+ !$omp declare variant (f1) simd ! { dg-error "expected 'match' or
'adjust_args' at .1." }
end subroutine
subroutine f8 ()
!$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." }
@@ -183,7 +183,7 @@ contains
!$omp declare variant (f1) match(construct={requires}) ! { dg-warning
"unknown selector 'requires' for context selector set 'construct' at .1." }
end subroutine
subroutine f75 ()
- !$omp declare variant (f1),match(construct={parallel}) ! { dg-error
"expected 'match' at .1." }
+ !$omp declare variant (f1),match(construct={parallel}) ! { dg-error
"expected 'match' or 'adjust_args' at .1." }
end subroutine
subroutine f76 ()
!$omp declare variant (f1)
match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error
"expected identifier at .1." }
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
new file mode 100644
index 00000000000..4e8bb129d40
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21-aux.f90
@@ -0,0 +1,18 @@
+! { dg-do compile { target skip-all-targets } }
+
+module my_mod
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine base_proc (a)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr), intent(inout) :: a
+ end subroutine
+ end interface
+
+contains
+ subroutine variant_proc (a)
+ type(c_ptr), intent(inout) :: a
+ !$omp declare variant (base_proc) match (construct={dispatch})
adjust_args(need_device_ptr: a)
+ end subroutine
+end module
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..022ae04dac0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-21.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-additional-sources declare-variant-21-aux.f90 }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test XFAILed due to https://gcc.gnu.org/PR115271
+
+
+subroutine base_proc (a)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr), intent(inout) :: a
+end subroutine
+
+program main
+ use iso_c_binding, only: c_ptr
+ use my_mod
+ implicit none
+
+ type(c_ptr) :: a
+
+
+ call base_proc(a)
+ !call variant_proc(a)
+
+ !$omp dispatch
+ call base_proc(a)
+! { dg-final { scan-tree-dump "variant_proc \\(&a\\)" "gimple" { xfail *-*-* }
} }
+
+end program main
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
new file mode 100644
index 00000000000..12c30904131
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-1.f90
@@ -0,0 +1,77 @@
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ contains
+
+ subroutine f1 ()
+ integer :: a, b, arr(10)
+ real :: x
+ complex :: c
+ character :: ch
+ logical :: bool
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+ type(struct) :: s
+ type(c_ptr) :: p
+
+ interface
+ subroutine f0 (a, c, bool, s)
+ import :: struct
+ integer, intent(in) :: a
+ complex, intent(out) :: c
+ logical, intent(inout) :: bool
+ type(struct) :: s
+ end subroutine
+ integer function f2 (arr, x, ch, b)
+ integer, intent(inout) :: arr(:)
+ real, intent(in) :: x
+ character, intent(out) :: ch
+ real :: b
+ end function
+ subroutine f3 (p)
+ import :: c_ptr
+ type(c_ptr) :: p
+ end subroutine
+ integer function f4 ()
+ end function
+ end interface
+
+ !$omp dispatch
+ b = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ c = f2(arr(:5), x * 2.4, ch, s%b)
+ !$omp dispatch
+ arr(1) = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ s%a = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ x = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ call f0(a, c, bool, s)
+ !$omp dispatch
+ call f0(f4(), c, bool, s)
+
+ !$omp dispatch nocontext(.TRUE.)
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(arr(2) < 10)
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(.FALSE.)
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(bool)
+ call f0(a, c, bool, s)
+ !$omp dispatch nowait
+ call f0(a, c, bool, s)
+ !$omp dispatch device(arr(9))
+ call f0(a, c, bool, s)
+ !$omp dispatch device(a + a)
+ call f0(a, c, bool, s)
+ !$omp dispatch device(-25373654)
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(p)
+ call f3(p)
+ !$omp dispatch depend(in: a, c, bool) depend(inout: s, arr(:3))
+ call f0(a, c, bool, s)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
new file mode 100644
index 00000000000..d2d555b5932
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-2.f90
@@ -0,0 +1,79 @@
+module main
+ use iso_c_binding, only: c_funptr
+ implicit none
+ contains
+
+ subroutine f1 ()
+ integer :: a, b, arr(10)
+ real :: x
+ complex :: c
+ character :: ch
+ logical :: bool
+ type :: struct
+ integer :: a
+ real :: b
+ end type
+ type(struct) :: s
+ type(c_funptr) :: p
+
+ interface
+ subroutine f0 (a, c, bool, s)
+ import :: struct
+ integer, intent(in) :: a
+ complex, intent(out) :: c
+ logical, intent(inout) :: bool
+ type(struct) :: s
+ end subroutine
+ integer function f2 (arr, x, ch, b)
+ integer, intent(inout) :: arr(:)
+ real, intent(in) :: x
+ character, intent(out) :: ch
+ real :: b
+ end function
+ end interface
+ procedure(f0), pointer:: fp => NULL()
+
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+50 b = f2(arr, x, ch, s%b) + a
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+ a = b
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
must be followed by a procedure call with optional assignment" }
+ b = Not (2)
+ !$omp dispatch
+ !$omp threadprivate(a) !{ dg-error "'OMP DISPATCH' directive must be
followed by a procedure call with optional assignment at .1." }
+ a = f2(arr, x, ch, s%b)
+ !$omp dispatch
+ print *, 'This is not allowed here.' !{ dg-error "'OMP DISPATCH'
directive must be followed by a procedure call with optional assignment at .1."
}
+ !$omp dispatch
+ goto 50 !{ dg-error "'OMP DISPATCH' directive must be
followed by a procedure call with optional assignment at .1." }
+ !$omp dispatch !{ dg-error "'OMP DISPATCH' directive at .1.
cannot be followed by a procedure pointer" }
+ call fp(a, c, bool, s)
+
+ !$omp dispatch nocontext(s) !{ dg-error "NOCONTEXT clause at .1. requires
a scalar LOGICAL expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(a, b) !{ dg-error "Invalid expression after
'nocontext.' at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch nocontext(a) nocontext(b) !{ dg-error "Duplicated
'nocontext' clause at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(s) !{ dg-error "NOVARIANTS clause at .1.
requires a scalar LOGICAL expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(a, b) !{ dg-error "Invalid expression after
'novariants.' at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch novariants(a) novariants(b) !{ dg-error "Duplicated
'novariants' clause at .1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch nowait nowait !{ dg-error "Duplicated 'nowait' clause at
.1." }
+ call f0(a, c, bool, s)
+ !$omp dispatch device(x) !{ dg-error "DEVICE clause at .1. requires a
scalar INTEGER expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch device(arr) !{ dg-error "DEVICE clause at .1. requires a
scalar INTEGER expression" }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(x) !{ dg-error "List item 'x' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(arr) !{ dg-error "List item 'arr' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch is_device_ptr(p) !{ dg-error "List item 'p' in
IS_DEVICE_PTR clause at .1. must be of TYPE.C_PTR." }
+ call f0(a, c, bool, s)
+ !$omp dispatch depend(inout: f0) !{ dg-error "Object 'f0' is not a
variable at .1." }
+ call f0(a, c, bool, s)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
new file mode 100644
index 00000000000..84590fd883a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-3.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ integer function f0 ()
+ end function
+
+ integer function f1 ()
+ end function
+
+ integer function f2 ()
+ !$omp declare variant (f0) match (construct={dispatch})
+ !$omp declare variant (f1) match (implementation={vendor(gnu)})
+ end function
+ end interface
+ contains
+
+ integer function test ()
+ integer :: a
+
+ !$omp dispatch
+ a = f2 ()
+ !$omp dispatch novariants(.TRUE.)
+ a = f2 ()
+ !$omp dispatch novariants(.FALSE.)
+ a = f2 ()
+ !$omp dispatch nocontext(.TRUE.)
+ a = f2 ()
+ !$omp dispatch nocontext(.FALSE.)
+ a = f2 ()
+ end function
+end module
+
+
+! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 3 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
new file mode 100644
index 00000000000..149d0613b97
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-4.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ subroutine f2 ()
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ !$omp dispatch ! { dg-final { scan-tree-dump-times "#pragma omp task
if\\(0\\)" 1 "gimple" } }
+ call f2 ()
+ !$omp dispatch nowait ! { dg-final { scan-tree-dump-times "#pragma omp task
if\\(1\\)" 1 "gimple" } }
+ call f2 ()
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
new file mode 100644
index 00000000000..e45397f3f96
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-5.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ implicit none
+ interface
+ subroutine f2 (a)
+ integer, intent(in) :: a
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ integer :: a
+
+ !$omp dispatch device(-25373654)
+ ! { dg-final { scan-tree-dump-times "__builtin_omp_set_default_device
\\(-25373654\\);" 1 "gimple" } }
+ call f2 (a)
+ !$omp dispatch device(a + a)
+ ! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = a.0_1 \\* 2;.*#pragma
omp dispatch device\\(D\.\[0-9]+\\) shared\\(D\.\[0-9]+\\).*#pragma omp task
shared\\(D\.\[0-9]+\\).*__builtin_omp_set_default_device \\(D\.\[0-9]+\\);" 1
"gimple" } }
+ call f2 (a)
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
new file mode 100644
index 00000000000..9f4fa2970ca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-6.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f1 (p, p2)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ type(c_ptr), intent(in) :: p2
+ end subroutine
+ subroutine f2 (p, p2)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ type(c_ptr), intent(in) :: p2
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args
(need_device_ptr: p, p2)
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ type(c_ptr) :: p, p2
+
+ !$omp dispatch
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p)
+ ! { dg-final { scan-tree-dump-times "#pragma omp task shared\\(p\\)
shared\\(p2\\)\[^\n\r]*\[ \t\n\r]*\{\[ \t\n\r]*integer\\(kind=4\\)
D\.\[0-9]+;\[ \t\n\r]*void \\* D\.\[0-9]+;\[ \t\n\r]*p = {CLOBBER};\[
\t\n\r]*D\.\[0-9]+ = __builtin_omp_get_default_device \\(\\);\[
\t\n\r]*D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(&p2, D\.\[0-9]+\\);\[
\t\n\r]*f1 \\(&p, D\.\[0-9]+\\);" 1 "gimple" } }
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p2)
+ ! { dg-final { scan-tree-dump-times "#pragma omp task shared\\(p2\\)
shared\\(p\\)\[^\n\r]*\[ \t\n\r]*\{\[ \t\n\r]*integer\\(kind=4\\) D\.\[0-9]+;\[
\t\n\r]*void \\* D\.\[0-9]+;\[ \t\n\r]*p = {CLOBBER};\[ \t\n\r]*D\.\[0-9]+ =
__builtin_omp_get_default_device \\(\\);\[ \t\n\r]*D\.\[0-9]+ =
__builtin_omp_get_mapped_ptr \\(&p, D\.\[0-9]+\\);\[ \t\n\r]*f1 \\(D\.\[0-9]+,
&p2\\);" 1 "gimple" } }
+ call f2 (p, p2)
+ !$omp dispatch is_device_ptr(p, p2)
+ ! { dg-final { scan-tree-dump-times "#pragma omp task shared\\(p\\)
shared\\(p2\\)\[^\n\r]*\[ \t\n\r]*\{\[ \t\n\r]*p = {CLOBBER};\[ \t\n\r]*f1
\\(&p, &p2\\);" 1 "gimple" } }
+ call f2 (p, p2)
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
new file mode 100644
index 00000000000..32b6347be67
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-7.f90
@@ -0,0 +1,27 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-ompexp" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f2 (p)
+ import :: c_ptr
+ type(c_ptr), intent(out) :: p
+ end subroutine
+ end interface
+ contains
+
+ subroutine test ()
+ type(c_ptr) :: p
+
+ !$omp dispatch
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_task \\(.*, .*, .*,
.*, .*, .*, 0B, .*, .*\\);" 1 "ompexp" } }
+ call f2 (p)
+ !$omp dispatch depend(inout: p)
+ ! { dg-final { scan-tree-dump-times "D\.\[0-9]+\\\[2] = &p;" 1 "ompexp" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_task \\(.*, .*, .*,
.*, .*, .*, &D\.\[0-9]+, .*, .*\\);" 1 "ompexp" } }
+ call f2 (p)
+ end subroutine
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
new file mode 100644
index 00000000000..6771336aa33
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-8.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple -fdump-tree-omplower" }
+
+module main
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ integer function f0 ()
+ end function
+ integer function f1 ()
+ end function
+ integer function f2 ()
+ !$omp declare variant (f0) match (construct={dispatch})
+ !$omp declare variant (f1) match (implementation={vendor(gnu)})
+ end function
+ end interface
+ contains
+
+ subroutine test ()
+ integer :: a, n
+
+ !$omp dispatch novariants(n < 1024) nocontext(n > 1024)
+ a = f2 ()
+ end subroutine
+end module
+
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n <= 1023;" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = n > 1024;" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch novariants\\(0\\)
nocontext\\(0\\) shared\\(D\.\[0-9]+\\) shared\\(D\.\[0-9]+\\)" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "#pragma omp task shared\\(D\.\[0-9]+\\)
shared\\(D\.\[0-9]+\\)" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f2 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f1 \\\(\\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "a = f0 \\\(\\\);" 1 "gimple" } }
+
+! { dg-final { scan-tree-dump-times ".omp_data_o.1.D\.\[0-9]+ = D\.\[0-9]+;" 2
"omplower" } }
+! { dg-final { scan-tree-dump-times ".omp_data_o.1.a = &a;" 1 "omplower" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = .omp_data_i->D\.\[0-9]+;" 2
"omplower" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = .omp_data_i->a;" 3
"omplower" } }
+! { dg-final { scan-tree-dump-times "\\*D\.\[0-9]+ = D\.\[0-9]+;" 3 "omplower"
} }
--
2.45.2
