This patch adds Fortran parsing support for OpenMP's 'interop' directive
(which stops with a 'sorry' in trans-openmp.cc as the middle end support
is still missing).
Tested on x86-64-gnu-linux.
Comments, suggestions, remarks?
* * *
Background:
'interop' makes it easier to call, e.g., a CUDA-BLAS function directly
as it permits to map an OpenMP device number (→ "target" modifier
required) to the "foreign runtime" device number or to get directly a
stream object (→ if "targetsync" modifier specified) with dependency
tracking.
Just calling '!$omp interop init(obj)' works but that leaves the
decision which type of object should be returned to the run time.
Using 'prefer_type', the user can ask for a specific type. Permits is a
string such as "hip" or an integer constant such as omp_ifr_cuda_driver
– and the old-style syntax is 'prefer_type(<const integer expr|literal
string> [ , <c.int expr|string> ...])'. [Note thatn a constant integer
expression is permitted.]
The new syntax permits additional attributes like for 'sycl' requesting
an 'in-order' queue (instead of the default 'out-of-order' queue when
obtaining a stream. The new syntax is 'prefer_type( {...} [, {...} ... }
) where '{ ... }' is a list of either 'attr("ompx_...")' (i.e.
'attr(...)' with literal string arg that starts with ompx_ and does not
contain a ',') or 'fr(<identifier|string literal>)' where the identifier
is an integer constant. 'fr' can be present or not, but only once per
{...} while multiple 'attr' may be used. [Note that as non-string only
an identifier is permitted (i.e. a integer parameter).]
I decided for the used way to encode the string – but I am open to other
representations as well. In my WIP/RFC patch is is used as shown in
plugin-*.c in the patch
https://gcc.gnu.org/pipermail/gcc-patches/2024-August/661207.html
The available foreign runtimes and values that can be returned values
are hidden in that patch and more readable in the documentation patch at
https://gcc.gnu.org/pipermail/gcc-patches/2024-August/661365.html
If someone wants to delve into the details of the 'interop' feature:
Have a look at OpenMP 5.1 (5.2) *and* TR13 and the additional definition
document at https://www.openmp.org/specifications/ ('hsa': publishing
pending).
* * *
Tobias
PS: In the dump, I am a bit lazy and add spurious tailing ','. As it is
only a dump, I decided adding a bunch of checks to ensure that a ','
only gets printed if needed is not really required. If you think
otherwise, I can surely add a bunch of 'if' an only print it conditionally.
PPS: In order to to use 'interop', mainly the part in middle is missing,
i.e. some middle-end gimplification with a call into libgomp – and the
libgomp function. A stub version of the latter and some (loosely) tested
plugin handling does exist as WIP/RFC patch, see patch link above. -
Besides gimplify and the libgomp function, a bunch of tests and,
obviously, the C and C++ FE counterpart to this patch have to be
implemented.
Fortran: Add OpenMP 'interop' directive parsing support
Parse OpenMP's 'interop' directive but stop with a 'sorry, unimplemented'
after resolving.
Additionally, it moves some clause dumping away from the end directive as
that lead to 'nowait' not being printed when it should as some cases were
missed.
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_namelist): Handle OMP_LIST_INIT.
(show_omp_clauses): Handle OMP_LIST_{INIT,USE,DESTORY}; move 'nowait'
from end-directive to the directive dump.
(show_omp_node, show_code_node): Handle EXEC_OMP_INTEROP.
* gfortran.h (enum gfc_statement): Add ST_OMP_INTEROP.
(OMP_LIST_INIT, OMP_LIST_USE, OMP_LIST_DESTROY): Add.
(enum gfc_exec_op): Add EXEC_OMP_INTEROP.
(struct gfc_omp_namelist): Add interop items to union.
(gfc_free_omp_namelist): Add boolean arg.
* match.cc (gfc_free_omp_namelist): Update to free
interop union members.
* match.h (gfc_match_omp_interop): New.
* openmp.cc (gfc_omp_directives): Uncomment 'interop' entry.
(gfc_free_omp_clauses, gfc_match_omp_allocate,
gfc_match_omp_flush, gfc_match_omp_clause_reduction): Update
call.
(enum omp_mask2): Add OMP_CLAUSE_{INIT,USE,DESTROY}.
(OMP_INTEROP_CLAUSES): Use it.
(gfc_match_omp_clauses): Match those clauses.
(gfc_match_omp_prefer_type, gfc_match_omp_init,
gfc_match_omp_interop): New.
(resolve_omp_clauses): Handle interop clauses.
(omp_code_to_statement): Add ST_OMP_INTEROP.
(gfc_resolve_omp_directive): Add EXEC_OMP_INTEROP.
* parse.cc (decode_omp_directive): Parse 'interop' directive.
(next_statement, gfc_ascii_statement): Handle ST_OMP_INTEROP.
* st.cc (gfc_free_statement): Likewise
* resolve.cc (gfc_resolve_code): Handle EXEC_OMP_INTEROP.
* trans.cc (trans_code): Likewise.
* trans-openmp.cc (gfc_trans_omp_directive): Print 'sorry'
for EXEC_OMP_INTEROP.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/interop-1.f90: New test.
* gfortran.dg/gomp/interop-2.f90: New test.
* gfortran.dg/gomp/interop-3.f90: New test.
gcc/fortran/dump-parse-tree.cc | 61 +++--
gcc/fortran/gfortran.h | 17 +-
gcc/fortran/match.cc | 13 +-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.cc | 387 +++++++++++++++++++++++++--
gcc/fortran/parse.cc | 7 +
gcc/fortran/resolve.cc | 1 +
gcc/fortran/st.cc | 3 +-
gcc/fortran/trans-openmp.cc | 3 +
gcc/fortran/trans.cc | 3 +-
gcc/testsuite/gfortran.dg/gomp/interop-1.f90 | 62 +++++
gcc/testsuite/gfortran.dg/gomp/interop-2.f90 | 42 +++
gcc/testsuite/gfortran.dg/gomp/interop-3.f90 | 53 ++++
13 files changed, 616 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 80aa8ef84e7..0971e6cfee7 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1374,6 +1374,8 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
}
ns_iter = n->u2.ns;
}
+ else if (list_type == OMP_LIST_INIT && n != n2)
+ fputs (") INIT(", dumpfile);
if (list_type == OMP_LIST_ALLOCATE)
{
if (n->u2.allocator)
@@ -1525,6 +1527,39 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
fputs (", ", dumpfile);
continue;
}
+ else if (list_type == OMP_LIST_INIT)
+ {
+ int i = 0;
+ if (n->u.init.target)
+ fputs ("target,", dumpfile);
+ if (n->u.init.targetsync)
+ fputs ("targetsync,", dumpfile);
+ char *prefer_type = n->u.init.str;
+ if (n->u.init.len)
+ fputs ("prefer_type(", dumpfile);
+ if (n->u.init.len)
+ while (*prefer_type)
+ {
+ fputc ('{', dumpfile);
+ if (n->u2.interop_int && n->u2.interop_int[i] != 0)
+ fprintf (dumpfile, "fr(%d),", n->u2.interop_int[i]);
+ else if (prefer_type[0] != ' ' || prefer_type[1] != '\0')
+ fprintf (dumpfile, "fr(\"%s\"),", prefer_type);
+ prefer_type += 1 + strlen (prefer_type);
+
+ while (*prefer_type)
+ {
+ fprintf (dumpfile, "attr(\"%s\"),", prefer_type);
+ prefer_type += 1 + strlen (prefer_type);
+ }
+ fputc ('}', dumpfile);
+ ++prefer_type;
+ ++i;
+ }
+ if (n->u.init.len)
+ fputc (')', dumpfile);
+ fputc (':', dumpfile);
+ }
fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory");
if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT)
fputc (')', dumpfile);
@@ -1806,11 +1841,12 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
fputs (" UNTIED", dumpfile);
if (omp_clauses->mergeable)
fputs (" MERGEABLE", dumpfile);
+ if (omp_clauses->nowait)
+ fputs (" NOWAIT", dumpfile);
if (omp_clauses->collapse)
fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
- if (omp_clauses->lists[list_type] != NULL
- && list_type != OMP_LIST_COPYPRIVATE)
+ if (omp_clauses->lists[list_type] != NULL)
{
const char *type = NULL;
switch (list_type)
@@ -1855,6 +1891,9 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break;
case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break;
case OMP_LIST_USES_ALLOCATORS: type = "USES_ALLOCATORS"; break;
+ case OMP_LIST_INIT: type = "INIT"; break;
+ case OMP_LIST_USE: type = "USE"; break;
+ case OMP_LIST_DESTROY: type = "DESTROY"; break;
default:
gcc_unreachable ();
}
@@ -2186,6 +2225,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
case EXEC_OMP_ERROR: name = "ERROR"; break;
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+ case EXEC_OMP_INTEROP: name = "INTEROP"; break;
case EXEC_OMP_LOOP: name = "LOOP"; break;
case EXEC_OMP_MASKED: name = "MASKED"; break;
case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break;
@@ -2286,6 +2326,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_INTEROP:
case EXEC_OMP_LOOP:
case EXEC_OMP_ORDERED:
case EXEC_OMP_MASKED:
@@ -2379,6 +2420,7 @@ show_omp_node (int level, gfc_code *c)
|| c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
|| c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
|| c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
+ || c->op == EXEC_OMP_INTEROP
|| (c->op == EXEC_OMP_ORDERED && c->block == NULL))
return;
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
@@ -2401,19 +2443,7 @@ show_omp_node (int level, gfc_code *c)
fputc ('\n', dumpfile);
code_indent (level, 0);
fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name);
- if (omp_clauses != NULL)
- {
- if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
- {
- fputs (" COPYPRIVATE(", dumpfile);
- show_omp_namelist (OMP_LIST_COPYPRIVATE,
- omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
- fputc (')', dumpfile);
- }
- else if (omp_clauses->nowait)
- fputs (" NOWAIT", dumpfile);
- }
- else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
+ if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses)
fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name);
}
@@ -3529,6 +3559,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_INTEROP:
case EXEC_OMP_FLUSH:
case EXEC_OMP_LOOP:
case EXEC_OMP_MASKED:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 729d811d945..49fb7e9a3e3 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_INTEROP
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -1381,6 +1381,13 @@ typedef struct gfc_omp_namelist
struct gfc_symbol *memspace_sym;
bool lastprivate_conditional;
bool present_modifier;
+ struct
+ {
+ char *str;
+ int len;
+ bool target;
+ bool targetsync;
+ } init;
} u;
union
{
@@ -1389,6 +1396,7 @@ typedef struct gfc_omp_namelist
gfc_expr *allocator;
struct gfc_symbol *traits_sym;
struct gfc_omp_namelist *duplicate_of;
+ int *interop_int;
} u2;
struct gfc_omp_namelist *next;
locus where;
@@ -1433,6 +1441,9 @@ enum
OMP_LIST_HAS_DEVICE_ADDR,
OMP_LIST_ENTER,
OMP_LIST_USES_ALLOCATORS,
+ OMP_LIST_INIT,
+ OMP_LIST_USE,
+ OMP_LIST_DESTROY,
OMP_LIST_NUM /* Must be the last. */
};
@@ -3044,7 +3055,7 @@ enum gfc_exec_op
EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED,
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_UNROLL, EXEC_OMP_TILE, EXEC_OMP_INTEROP,
EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
@@ -3683,7 +3694,7 @@ void gfc_free_iterator (gfc_iterator *, int);
void gfc_free_forall_iterator (gfc_forall_iterator *);
void gfc_free_alloc_list (gfc_alloc *);
void gfc_free_namelist (gfc_namelist *);
-void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool);
+void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool, bool);
void gfc_free_equiv (gfc_equiv *);
void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
void gfc_free_data (gfc_data *);
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index d30a98f48fa..9aa49535d3d 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5540,10 +5540,11 @@ gfc_free_namelist (gfc_namelist *name)
void
gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
bool free_align_allocator,
- bool free_mem_traits_space)
+ bool free_mem_traits_space, bool free_init)
{
gfc_omp_namelist *n;
gfc_expr *last_allocator = NULL;
+ char *last_init_str = NULL;
for (; name; name = n)
{
@@ -5552,6 +5553,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
gfc_free_expr (name->u.align);
else if (free_mem_traits_space)
{ } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */
+
if (free_ns)
gfc_free_namespace (name->u2.ns);
else if (free_align_allocator)
@@ -5564,6 +5566,15 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
}
else if (free_mem_traits_space)
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
+ else if (free_init)
+ {
+ if (name->u.init.str != last_init_str)
+ {
+ last_init_str = name->u.init.str;
+ free (name->u.init.str);
+ free (name->u2.interop_int);
+ }
+ }
else if (name->u2.udr)
{
if (name->u2.udr->combiner)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index c2b7d69c37c..84d84b81825 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -172,6 +172,7 @@ match gfc_match_omp_do_simd (void);
match gfc_match_omp_loop (void);
match gfc_match_omp_error (void);
match gfc_match_omp_flush (void);
+match gfc_match_omp_interop (void);
match gfc_match_omp_masked (void);
match gfc_match_omp_masked_taskloop (void);
match gfc_match_omp_masked_taskloop_simd (void);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 333f0c7fe7f..827c1887302 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -18,6 +18,8 @@ You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
+#define INCLUDE_VECTOR
+#define INCLUDE_STRING
#include "config.h"
#include "system.h"
#include "coretypes.h"
@@ -78,7 +80,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = {
/* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
{"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
{"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
- /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
+ {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
{"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
{"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
/* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
@@ -193,7 +195,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_omp_namelist (c->lists[i],
i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
i == OMP_LIST_ALLOCATE,
- i == OMP_LIST_USES_ALLOCATORS);
+ i == OMP_LIST_USES_ALLOCATORS,
+ i == OMP_LIST_INIT);
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
gfc_free_expr_list (c->sizes_list);
@@ -559,7 +562,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false, false);
+ gfc_free_omp_namelist (head, false, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -649,7 +652,7 @@ syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false, false);
+ gfc_free_omp_namelist (head, false, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -758,7 +761,7 @@ syntax:
gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
cleanup:
- gfc_free_omp_namelist (head, false, false, false);
+ gfc_free_omp_namelist (head, false, false, false, false);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -1106,6 +1109,9 @@ enum omp_mask2
OMP_CLAUSE_FULL, /* OpenMP 5.1. */
OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
+ OMP_CLAUSE_INIT, /* OpenMP 5.1. */
+ OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
+ OMP_CLAUSE_USE, /* OpenMP 5.1. */
/* This must come last. */
OMP_MASK2_LAST
};
@@ -1517,7 +1523,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
buffer, &old_loc);
- gfc_free_omp_namelist (n, false, false, false);
+ gfc_free_omp_namelist (n, false, false, false, false);
}
else
for (n = *head; n; n = n->next)
@@ -1808,11 +1814,305 @@ gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
return MATCH_YES;
error:
- gfc_free_omp_namelist (head, false, false, true);
+ gfc_free_omp_namelist (head, false, false, true, false);
return MATCH_ERROR;
}
+/* Match the 'prefer_type' modifier of the interop 'init' clause:
+ with either OpenMP 5.1's
+ prefer_type ( <const-int-expr|string literal> [, ...]
+ or
+ prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
+ where 'fr' takes an integer named constant or a string literal
+ and 'attr takes a string literal, starting with 'ompx_')
+
+Document string + int format
+*/
+
+static match
+gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_array)
+{
+ gfc_expr *e;
+ size_t cnt = 0;
+ std::vector<int> int_list;
+ std::string pref_string;
+ /* New syntax. */
+ if (gfc_peek_ascii_char () == '{')
+ do
+ {
+ if (gfc_match ("{ ") != MATCH_YES)
+ {
+ gfc_error ("Expected %<{%> at %C");
+ return MATCH_ERROR;
+ }
+ std::string attr;
+ bool fr_found = false;
+ do
+ {
+ if (gfc_match ("fr ( ") == MATCH_YES)
+ {
+ if (fr_found)
+ {
+ gfc_error ("Duplicated %<fr%> preference-selector-name "
+ "at %C");
+ return MATCH_ERROR;
+ }
+ fr_found = true;
+ gfc_symbol *sym = NULL;
+ locus loc = gfc_current_locus;
+ if (gfc_match_symbol (&sym, 0) != MATCH_YES
+ || gfc_match (" _") == MATCH_YES)
+ {
+ gfc_current_locus = loc;
+ if (gfc_match_expr (&e) == MATCH_ERROR)
+ return MATCH_ERROR;
+ }
+ if ((!sym && !e)
+ || (e && (!gfc_resolve_expr (e)
+ || e->expr_type != EXPR_CONSTANT
+ || e->ts.type != BT_CHARACTER
+ || e->ts.kind != gfc_default_character_kind
+ || e->value.character.length == 0))
+ || (sym && (sym->attr.flavor != FL_PARAMETER
+ || sym->ts.type != BT_INTEGER
+ || !mpz_fits_sint_p (sym->value->value.integer)
+ || sym->attr.dimension)))
+ {
+ gfc_error ("Expected constant integer identifier or "
+ "non-empty default-kind character literal at %L",
+ &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ if (sym)
+ {
+ for (size_t i = int_list.size(); i < cnt; ++i)
+ int_list.push_back (0);
+ int_list.push_back (mpz_get_si (sym->value->value.integer));
+ pref_string += ' ';
+ pref_string += '\0';
+ }
+ else
+ {
+ char *str = XALLOCAVEC (char, e->value.character.length+1);
+ for (int i = 0; i < e->value.character.length + 1; i++)
+ str[i] = e->value.character.string[i];
+ if (memchr (str, '\0', e->value.character.length) != 0)
+ {
+ gfc_error ("Unexpected null character in character "
+ "literal at %L", &loc);
+ return MATCH_ERROR;
+ }
+ pref_string += str;
+ pref_string += '\0';
+ }
+ }
+ else if (gfc_match ("attr ( ") == MATCH_YES)
+ {
+ locus loc = gfc_current_locus;
+ if (gfc_match_expr (&e) != MATCH_YES
+ || e->expr_type != EXPR_CONSTANT
+ || e->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("Expected default-kind character literal at %L",
+ &loc);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ char *str = XALLOCAVEC (char, e->value.character.length+1);
+ for (int i = 0; i < e->value.character.length + 1; i++)
+ str[i] = e->value.character.string[i];
+ if (!startswith (str, "ompx_"))
+ {
+ gfc_error ("Character literal at %L must start with "
+ "%<ompx_%>", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ if (memchr (str, '\0', e->value.character.length) != 0
+ || memchr (str, ',', e->value.character.length) != 0)
+ {
+ gfc_error ("Unexpected null or %<,%> character in "
+ "character literal at %L", &e->where);
+ return MATCH_ERROR;
+ }
+ attr += str;
+ attr += '\0';
+ }
+ else
+ {
+ gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
+ return MATCH_ERROR;
+ }
+ ++cnt;
+ if (gfc_match (") ") != MATCH_YES)
+ {
+ gfc_error ("Expected %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match ("} ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<}%> at %C");
+ return MATCH_ERROR;
+ }
+ while (true);
+ if (!fr_found)
+ {
+ pref_string += ' ';
+ pref_string += '\0';
+ }
+ pref_string += attr;
+ pref_string += '\0';
+
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ while (true);
+ else
+ do
+ {
+ if (gfc_match_expr (&e) != MATCH_YES)
+ return MATCH_ERROR;
+ if (!gfc_resolve_expr (e)
+ || e->expr_type != EXPR_CONSTANT
+ || (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER)
+ || (e->ts.type == BT_INTEGER
+ && !mpz_fits_sint_p (e->value.integer))
+ || (e->ts.type == BT_CHARACTER
+ && (e->ts.kind != gfc_default_character_kind
+ || e->value.character.length == 0)))
+ {
+ gfc_error ("Expected constant integer expression or non-empty "
+ "default-kind character literal at %L", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ if (e->ts.type == BT_INTEGER)
+ {
+ for (size_t i = int_list.size(); i < cnt; ++i)
+ int_list.push_back (0);
+ int_list.push_back (mpz_get_si (e->value.integer));
+ pref_string += ' ';
+ }
+ else
+ {
+ char *str = XALLOCAVEC (char, e->value.character.length+1);
+ for (int i = 0; i < e->value.character.length + 1; i++)
+ str[i] = e->value.character.string[i];
+ if (memchr (str, '\0', e->value.character.length) != 0)
+ {
+ gfc_error ("Unexpected null character in character literal "
+ "at %L", &e->where);
+ return MATCH_ERROR;
+ }
+ pref_string += str;
+ }
+ pref_string += '\0';
+ pref_string += '\0';
+ ++cnt;
+ gfc_free_expr (e);
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
+ return MATCH_ERROR;
+ }
+ while (true);
+ if (!int_list.empty())
+ for (size_t i = int_list.size(); i < cnt; ++i)
+ int_list.push_back (0);
+
+ pref_string += '\0';
+
+ *pref_str_len = pref_string.length();
+ *pref_str = XNEWVEC (char, pref_string.length ());
+ memcpy (*pref_str, pref_string.data (), pref_string.length ());
+ if (!int_list.empty ())
+ {
+ *pref_int_array = XNEWVEC (int, cnt);
+ memcpy (*pref_int_array, int_list.data (), sizeof (int) * cnt);
+ }
+ return MATCH_YES;
+}
+
+
+/* Match OpenMP 5.1's 'init' clause for 'interop' objects:
+ init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
+
+static match
+gfc_match_omp_init (gfc_omp_namelist **list)
+{
+ /* Assume that no variable named 'prefer_type', 'target' or 'targetsync'
+ exists. */
+ bool target = false, targetsync = false;
+ char *pref_str = NULL;
+ int pref_str_len = 0;
+ int *pref_int_array = NULL;
+ match m;
+ do {
+ if (gfc_match ("prefer_type ( ") == MATCH_YES)
+ {
+ if (pref_str)
+ {
+ gfc_error ("Duplicate %<prefer_type%> modifier at %C");
+ return MATCH_ERROR;
+ }
+ m = gfc_match_omp_prefer_type (&pref_str, &pref_str_len,
+ &pref_int_array);
+ if (m != MATCH_YES)
+ return m;
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (": ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match ("targetsync ") == MATCH_YES)
+ {
+ targetsync = true;
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (": ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match ("target ") == MATCH_YES)
+ {
+ target = true;
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (": ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<:%> at %C");
+ }
+ break;
+ }
+ while (true);
+
+ gfc_omp_namelist **head = NULL;
+ m = gfc_match_omp_variable_list ("", list, false, NULL, &head);
+ for (gfc_omp_namelist *n = *head; n; n = n->next)
+ {
+ n->u.init.target = target;
+ n->u.init.targetsync = targetsync;
+ n->u.init.str = pref_str;
+ n->u.init.len = pref_str_len;
+ n->u2.interop_int = pref_int_array;
+ }
+ return m;
+}
+
+
/* Match with duplicate check. Matches 'name'. If expr != NULL, it
then matches '(expr)', otherwise, if open_parens is true,
it matches a ' ( ' after 'name'.
@@ -1934,7 +2234,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false, false);
+ gfc_free_omp_namelist (*head, false, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -2498,6 +2798,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
continue;
}
+ if ((mask & OMP_CLAUSE_DESTROY)
+ && gfc_match_omp_variable_list ("destroy (",
+ &c->lists[OMP_LIST_DESTROY],
+ true) == MATCH_YES)
+ continue;
if ((mask & OMP_CLAUSE_DETACH)
&& !openacc
&& !c->detach
@@ -2856,6 +3161,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
c->indirect = 1;
continue;
}
+ if ((mask & OMP_CLAUSE_INIT)
+ && gfc_match ("init ( ") == MATCH_YES)
+ {
+ m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
+ if (m == MATCH_YES)
+ continue;
+ goto error;
+ }
if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
&& gfc_match_omp_variable_list
("is_device_ptr (",
@@ -2929,7 +3242,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
end_colon = true;
else if (gfc_match (" )") != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false, false);
+ gfc_free_omp_namelist (*head, false, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
break;
@@ -2940,7 +3253,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
{
if (gfc_match (" %e )", &step) != MATCH_YES)
{
- gfc_free_omp_namelist (*head, false, false, false);
+ gfc_free_omp_namelist (*head, false, false, false, false);
gfc_current_locus = old_loc;
*head = NULL;
goto error;
@@ -3037,7 +3350,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
if (has_error)
{
- gfc_free_omp_namelist (*head, false, false, false);
+ gfc_free_omp_namelist (*head, false, false, false, false);
*head = NULL;
goto error;
}
@@ -3774,6 +4087,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_USE)
+ && gfc_match_omp_variable_list ("use (",
+ &c->lists[OMP_LIST_USE],
+ true) == MATCH_YES)
+ continue;
if ((mask & OMP_CLAUSE_USE_DEVICE)
&& gfc_match_omp_variable_list ("use_device (",
&c->lists[OMP_LIST_USE_DEVICE],
@@ -4590,6 +4908,9 @@ cleanup:
(omp_mask (OMP_CLAUSE_SIZES))
#define OMP_ALLOCATORS_CLAUSES \
omp_mask (OMP_CLAUSE_ALLOCATE)
+#define OMP_INTEROP_CLAUSES \
+ (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
+ | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
static match
@@ -4669,7 +4990,7 @@ gfc_match_omp_allocate (void)
gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
"directive", &n->expr->where);
- gfc_free_omp_namelist (vars, false, true, false);
+ gfc_free_omp_namelist (vars, false, true, false, false);
goto error;
}
@@ -5082,14 +5403,14 @@ gfc_match_omp_flush (void)
{
gfc_error ("List specified together with memory order clause in FLUSH "
"directive at %C");
- gfc_free_omp_namelist (list, false, false, false);
+ gfc_free_omp_namelist (list, false, false, false, false);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
- gfc_free_omp_namelist (list, false, false, false);
+ gfc_free_omp_namelist (list, false, false, false, false);
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
@@ -5768,6 +6089,14 @@ gfc_ignore_trait_property_extension_list (void)
}
}
+
+match
+gfc_match_omp_interop (void)
+{
+ return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
+}
+
+
/* OpenMP 5.0:
trait-selector:
@@ -7618,7 +7947,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", "INIT", "USE", "DESTROY" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
@@ -8001,6 +8330,29 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
}
}
+ if (code
+ && code->op == EXEC_OMP_INTEROP
+ && omp_clauses->lists[OMP_LIST_DEPEND])
+ {
+ if (!omp_clauses->lists[OMP_LIST_INIT]
+ && !omp_clauses->lists[OMP_LIST_USE]
+ && !omp_clauses->lists[OMP_LIST_DESTROY])
+ {
+ gfc_error ("DEPEND clause at %L requires action clause with "
+ "%<targetsync%> interop-type",
+ &omp_clauses->lists[OMP_LIST_DEPEND]->where);
+ }
+ for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
+ if (!n->u.init.targetsync)
+ {
+ gfc_error ("DEPEND clause at %L requires %<targetsync%> "
+ "interop-type, lacking it for %qs at %L",
+ &omp_clauses->lists[OMP_LIST_DEPEND]->where,
+ n->sym->name, &n->where);
+ break;
+ }
+ }
+
/* Detect specifically the case where we have "map(x) private(x)" and raise
an error. If we have "...simd" combined directives though, the "private"
applies to the simd part, so this is permitted though. */
@@ -8130,7 +8482,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
prev->next = n->next;
n->next = NULL;
- gfc_free_omp_namelist (n, false, true, false);
+ gfc_free_omp_namelist (n, false, true, false, false);
n = prev->next;
}
continue;
@@ -11283,6 +11635,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_ERROR;
case EXEC_OMP_FLUSH:
return ST_OMP_FLUSH;
+ case EXEC_OMP_INTEROP:
+ return ST_OMP_INTEROP;
case EXEC_OMP_DISTRIBUTE:
return ST_OMP_DISTRIBUTE;
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
@@ -11841,6 +12195,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_INTEROP:
case EXEC_OMP_MASKED:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL_WORKSHARE:
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index a814b7910d3..c506e18233e 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -1165,6 +1165,9 @@ decode_omp_directive (void)
case 'f':
matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
break;
+ case 'i':
+ matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP);
+ break;
case 'm':
matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd,
ST_OMP_MASKED_TASKLOOP_SIMD);
@@ -1881,6 +1884,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
+ case ST_OMP_INTEROP: \
case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
@@ -2810,6 +2814,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OMP_FLUSH:
p = "!$OMP FLUSH";
break;
+ case ST_OMP_INTEROP:
+ p = "!$OMP INTEROP";
+ break;
case ST_OMP_LOOP:
p = "!$OMP LOOP";
break;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 5db327cd12b..8ac06376892 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -13237,6 +13237,7 @@ start:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_INTEROP:
case EXEC_OMP_LOOP:
case EXEC_OMP_MASTER:
case EXEC_OMP_MASTER_TASKLOOP:
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 0218d290782..904b0008070 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -229,6 +229,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_ERROR:
+ case EXEC_OMP_INTEROP:
case EXEC_OMP_LOOP:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_MASKED_TASKLOOP:
@@ -290,7 +291,7 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_OMP_FLUSH:
- gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false);
+ gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false, false);
break;
case EXEC_OMP_BARRIER:
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index df1bf144e23..3a335ade0f7 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -8358,6 +8358,9 @@ gfc_trans_omp_directive (gfc_code *code)
return gfc_trans_omp_teams (code, NULL, NULL_TREE);
case EXEC_OMP_WORKSHARE:
return gfc_trans_omp_workshare (code, code->ext.omp_clauses);
+ case EXEC_OMP_INTEROP:
+ sorry ("%<!$OMP INTEROP%>");
+ return build_empty_stmt (input_location);
default:
gcc_unreachable ();
}
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index ce4618562b7..da6c2543612 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2606,9 +2606,10 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
- case EXEC_OMP_LOOP:
case EXEC_OMP_ERROR:
case EXEC_OMP_FLUSH:
+ case EXEC_OMP_INTEROP:
+ case EXEC_OMP_LOOP:
case EXEC_OMP_MASKED:
case EXEC_OMP_MASKED_TASKLOOP:
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
new file mode 100644
index 00000000000..bbb1dea1be6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
@@ -0,0 +1,62 @@
+module m
+ use iso_c_binding
+ implicit none
+
+ ! The following definitions are in omp_lib, which cannot be included
+ ! in gcc/testsuite/
+ integer, parameter :: omp_interop_kind = c_intptr_t
+ integer, parameter :: omp_interop_fr_kind = c_int
+
+ integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7
+end module m
+
+subroutine sub1
+ !$omp interop
+ integer :: y ! { dg-error "Unexpected data declaration statement" }
+end subroutine sub1
+
+program main
+use m
+implicit none
+
+!$omp requires reverse_offload
+
+integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
+integer :: x
+
+!$omp interop init(obj1) init(target,targetsync,target,targetsync : obj2, obj3) nowait
+
+!$omp interop init(prefer_type("cu"//"da", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) &
+!$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0)
+
+!$omp assume contains(interop)
+ !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3)
+!$omp end assume
+
+!$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "Unexpected null character in character literal" }
+
+!$omp interop depend(inout: x) , use(obj2), destroy(obj3) ! OK, use or destory might have 'targetsync'
+
+!$omp interop depend(inout: x) use(obj2), destroy(obj3) ! Likewise
+
+!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(prefer_type("cuda"), targetsync : obj4) ! OK
+
+!$omp interop init ( target , prefer_type( { fr("hsa") }, "hip") : obj1) ! { dg-error "Expected '\{' at .1." }
+
+!$omp interop init ( target , prefer_type( { fr("hsa"), attr("ompx_nothing") , fr("hsa" ) }) :obj1) ! { dg-error "Duplicated 'fr' preference-selector-name" }
+
+!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1)
+!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4) }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4_"cuda") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(c_char_"cuda") }) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(1_"cuda") }) : obj1) ! OK
+
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90
new file mode 100644
index 00000000000..da57c8afe16
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90
@@ -0,0 +1,42 @@
+module m
+ use iso_c_binding
+ implicit none
+
+ ! The following definitions are in omp_lib, which cannot be included
+ ! in gcc/testsuite/
+ integer, parameter :: omp_interop_kind = c_intptr_t
+ integer, parameter :: omp_interop_fr_kind = c_int
+
+ integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7
+end module m
+
+program main
+use m
+implicit none
+
+!$omp requires reverse_offload
+
+integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
+integer :: x
+
+!$omp interop init ( prefer_type( {fr(1_"") }) : obj1) ! { dg-error "Expected constant integer identifier or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr(omp_ifr_cuda) }) : obj1) ! { dg-error "Expected default-kind character literal" }
+
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr("myooption") }) : obj1) ! { dg-error "Character literal at .1. must start with 'ompx_'" }
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") , attr("ompx_") } ) : obj1)
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") }, { attr("ompx_") } ) : obj1)
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") } { attr("ompx_") } ) : obj1) ! { dg-error "Expected ',' or '\\)'" }
+!$omp interop init ( prefer_type( {fr(1_"hip") , attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" }
+
+!$omp interop init ( prefer_type( {fr(1_"hip") attr("ompx_option") ) : obj1) ! { dg-error "Expected ',' or '\}'" }
+!$omp interop init ( prefer_type( {fr(1_"hip")}), prefer_type("cuda") : obj1) ! { dg-error "Duplicate 'prefer_type' modifier" }
+
+!$omp interop init ( prefer_type( {attr("ompx_option1,ompx_option2") ) : obj1) ! { dg-error "Unexpected null or ',' character in character literal" }
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90
new file mode 100644
index 00000000000..59667f6e061
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90
@@ -0,0 +1,53 @@
+module m
+ use iso_c_binding
+ implicit none
+
+ ! The following definitions are in omp_lib, which cannot be included
+ ! in gcc/testsuite/
+ integer, parameter :: omp_interop_kind = c_intptr_t
+ integer, parameter :: omp_interop_fr_kind = c_int
+
+ integer (omp_interop_kind), parameter :: omp_interop_none = 0_omp_interop_kind
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6
+ integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7
+end module m
+
+program main
+use m
+implicit none
+
+!$omp requires reverse_offload
+
+integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
+integer :: x
+
+!$omp interop init(obj1) init(target,targetsync,target,targetsync : obj2, obj3) nowait
+
+!$omp interop init(prefer_type("cu"//"da", omp_ifr_opencl, omp_ifr_level_zero, "hsa"), targetsync : obj1) &
+!$omp& destroy(obj2, obj3) depend(inout: x) use(obj4, obj5) device(device_num: 0)
+
+!$omp assume contains(interop)
+ !$omp interop init(prefer_type("cu"//char(1)//"da") : obj3)
+!$omp end assume
+
+!$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4)
+! { dg-error "Symbol 'obj1' present on multiple clauses" "" { target *-*-* } .-1 }
+! { dg-error "Symbol 'obj4' present on multiple clauses" "" { target *-*-* } .-2 }
+
+!$omp interop depend(inout: x) ! { dg-error "DEPEND clause at .1. requires action clause with 'targetsync' interop-type" }
+
+!$omp interop depend(inout: x) , use(obj2), destroy(obj3) ! OK, use or destory might have 'targetsync'
+
+!$omp interop depend(inout: x) use(obj2), destroy(obj3) ! Likewise
+
+!$omp interop depend(inout: x) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." }
+
+!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(obj4) ! { dg-error "DEPEND clause at .1. requires 'targetsync' interop-type, lacking it for 'obj4' at .2." }
+!$omp interop depend(inout: x) init(targetsync : obj5) use(obj2), destroy(obj3) init(prefer_type("cuda"), targetsync : obj4) ! OK
+
+end
