This patch fixes a couple of issues, like a missing white-space gobbling
after matching an expression.
It also reorganizes some code to handle 'identifier_"string"' vs.
'identifier' better as there were some diagnostic issues.
(OpenMP requires for 'fr' that the argument is either an identifier
(that is a scalar integer parameter) or a string; while for the older
syntax, it can be any constant integer expression.)
However, the two main changes are:
* 'fr' and 'attr' actually support a list of arguments. While I believe
'attr("x", "y") and "attr("x"),attr("y")' are semantically identically,
supporting more than one (or zero) values for 'fr' required a different
encoding.
* Jakub additionally suggested that for 'fr', which supports constant
integers and string literals, we could pass on integer values – and do
some checking.
That's what this patch does: Known string values are converted to their
associated integer values, others to 0. And if the integer/string value
is unknown, a warning is printed [-Wopenmp].
Known values are those in the "OpenMP API Additional Definitions"
document, https://www.openmp.org/specifications/ – with the addition of
hsa / 7, which has been voted at spec level (no idea about ARB level)
but not yet published.
Note that that's the warning is based on what is defined there, i.e.
'level_zero' there is no warning, even though GCC does not support it.
Obviously, if will add another value next year, GCC 15 will not support
it and warn, even if the code is perfectly valid. — But I guess we can
live with a warning in that case.
Comments, remarks, suggestions? — Especially regarding the internal
representation?
Tobias
PS: Next step will be to get the C/C++ parsing working, which also
implies encoding this representation into 'tree'. (Then doing the tree
conversion for Fortran.) Once satisfied with that, the middle end +
libgomp part that links those bits will come next. And the question
whether there should be one call per 'interop' directive or might be
multiple (e.g. one per interop object in 'init'/'use'/'destroy').
Fortran: Fixes to OpenMP 'interop' directive parsing support
Handle lists as argument to 'fr' and 'attr'; fix parsing corner cases.
Additionally, 'fr' values are now internally stored as integer, permitting
the diagnoses (warning) for values not defined in the OpenMP additional
definitions document.
PR fortran/116661
gcc/fortran/ChangeLog:
* gfortran.h (gfc_omp_namelist): Rename 'init' members for clarity.
* match.cc (gfc_free_omp_namelist): Handle renaming.
* dump-parse-tree.cc (show_omp_namelist): Update for new format
and features.
* openmp.cc (gfc_match_omp_prefer_type): Parse list to 'fr' and 'attr';
store 'fr' values as integer.
(gfc_match_omp_init): Rename variable names.
gcc/ChangeLog:
* omp-api.h (omp_get_fr_id_from_name, omp_get_name_from_fr_id): New
prototypes.
* omp-general.cc (omp_get_fr_id_from_name, omp_get_name_from_fr_id):
New.
include/ChangeLog:
* gomp-constants.h (GOMP_INTEROP_IFR_LAST,
GOMP_INTEROP_IFR_SEPARATOR, GOMP_INTEROP_IFR_NONE): New.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/interop-1.f90: Extend, update dg-*.
* gfortran.dg/gomp/interop-2.f90: Update dg-error.
* gfortran.dg/gomp/interop-3.f90: Add dg-warning.
gcc/fortran/dump-parse-tree.cc | 84 +++++---
gcc/fortran/gfortran.h | 4 +-
gcc/fortran/match.cc | 10 +-
gcc/fortran/openmp.cc | 305 ++++++++++++++++-----------
gcc/omp-api.h | 3 +
gcc/omp-general.cc | 29 +++
gcc/testsuite/gfortran.dg/gomp/interop-1.f90 | 32 ++-
gcc/testsuite/gfortran.dg/gomp/interop-2.f90 | 2 +-
gcc/testsuite/gfortran.dg/gomp/interop-3.f90 | 2 +-
include/gomp-constants.h | 5 +
10 files changed, 314 insertions(+), 162 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 8fc6141611c..3547d7f8aca 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -37,6 +37,8 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
#include "version.h"
#include "parse.h" /* For gfc_ascii_statement. */
+#include "omp-api.h" /* For omp_get_name_from_fr_id. */
+#include "gomp-constants.h" /* For GOMP_INTEROP_IFR_SEPARATOR. */
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
@@ -1537,35 +1539,69 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
}
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->u2.init_interop_fr)
+ {
+ char *attr_str = n->u.init.attr;
+ int idx = 0;
+ int fr_id;
+ fputs ("prefer_type(", dumpfile);
+ do
+ {
+ fr_id = n->u2.init_interop_fr[idx];
+ fputc ('{', dumpfile);
+ if (fr_id != GOMP_INTEROP_IFR_NONE)
+ {
+ fputs ("fr(", dumpfile);
+ do
+ {
+ const char *fr_str = omp_get_name_from_fr_id (fr_id);
+ if (fr_str)
+ fprintf (dumpfile, "\"%s\"", fr_str);
+ else
+ fprintf (dumpfile, "%d", fr_id);
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (fr_id != GOMP_INTEROP_IFR_SEPARATOR)
+ fputc (',', dumpfile);
+ }
+ while (fr_id != GOMP_INTEROP_IFR_SEPARATOR);
+ fputc (')', dumpfile);
+ if (attr_str && (attr_str[0] != ' ' || attr_str[1] != '\0'))
+ fputc (',', dumpfile);
+ }
+ else
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (attr_str && attr_str[0] == ' ' && attr_str[1] == '\0')
+ attr_str += 2;
+ else if (attr_str)
+ {
+ fputs ("attr(\"", dumpfile);
+ do
+ {
+ fputs ((char *) attr_str, dumpfile);
+ fputc ('"', dumpfile);
+ attr_str += strlen (attr_str) + 1;
+ if (attr_str[0] == '\0')
+ break;
+ fputs (",\"", dumpfile);
+ }
+ while (true);
+ fputc (')', dumpfile);
+ }
+ fputc ('}', dumpfile);
+ fr_id = n->u2.init_interop_fr[++idx];
+ if (fr_id == GOMP_INTEROP_IFR_SEPARATOR)
+ break;
+ fputc (',', dumpfile);
+ if (attr_str)
+ ++attr_str;
+ }
+ while (true);
+ fputc (')', dumpfile);
}
- if (n->u.init.len)
- fputc (')', dumpfile);
fputc (':', dumpfile);
}
fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory");
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 797d4ed07f5..37c28691f41 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1389,7 +1389,7 @@ typedef struct gfc_omp_namelist
bool present_modifier;
struct
{
- char *str;
+ char *attr;
int len;
bool target;
bool targetsync;
@@ -1402,7 +1402,7 @@ typedef struct gfc_omp_namelist
gfc_expr *allocator;
struct gfc_symbol *traits_sym;
struct gfc_omp_namelist *duplicate_of;
- int *interop_int;
+ char *init_interop_fr;
} u2;
struct gfc_omp_namelist *next;
locus where;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index f3767c928a7..0cd78a57a2f 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5551,7 +5551,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
{
gfc_omp_namelist *n;
gfc_expr *last_allocator = NULL;
- char *last_init_str = NULL;
+ char *last_init_attr = NULL;
for (; name; name = n)
{
@@ -5575,11 +5575,11 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
else if (free_init)
{
- if (name->u.init.str != last_init_str)
+ if (name->u.init.attr != last_init_attr)
{
- last_init_str = name->u.init.str;
- free (name->u.init.str);
- free (name->u2.interop_int);
+ last_init_attr = name->u.init.attr;
+ free (name->u.init.attr);
+ free (name->u2.init_interop_fr);
}
}
else if (name->u2.udr)
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 1145e2ff890..050409e00a0 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -1827,16 +1827,31 @@ error:
where 'fr' takes an integer named constant or a string literal
and 'attr takes a string literal, starting with 'ompx_')
-Document string + int format
-*/
+ For the foreign runtime identifiers, string values are converted to
+ their integer value; unknown string or integer values are set to 0.
+
+ For the simple syntax, pref_int_array contains alternatingly the
+ fr_id integer value and GOMP_INTEROP_IFR_SEPARATOR followed by a
+ GOMP_INTEROP_IFR_SEPARATOR as last item.
+ For the complex syntax, it contains the values associated with a
+ 'fr(...)' followed by GOMP_INTEROP_IFR_SEPARATOR. If there is no
+ 'fr' in a curly-brace block, it is GOMP_INTEROP_IFR_NONE followed
+ by GOMP_INTEROP_IFR_SEPARATOR. An additional GOMP_INTEROP_IFR_SEPARATOR
+ at the end terminates the array.
+
+ For attributes, if the simply syntax is used, it is NULL - likewise if no
+ 'attr' appears. For the complex syntax it is: For reach curly-brace block,
+ it is \0\0 is no attr appears and otherwise a concatenation (including
+ the \0) of all 'attr' strings followed by a tailing '\0'. At the end,
+ another '\0' follows. */
static match
-gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_array)
+gfc_match_omp_prefer_type (char **fr_int_array, char **attr_str, int *attr_str_len)
{
gfc_expr *e;
- size_t cnt = 0;
- std::vector<int> int_list;
- std::string pref_string;
+ int cnt_brace_grp = 0;
+ std::vector<char> int_list;
+ std::string attr_string;
/* New syntax. */
if (gfc_peek_ascii_char () == '{')
do
@@ -1846,8 +1861,8 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
gfc_error ("Expected %<{%> at %C");
return MATCH_ERROR;
}
- std::string attr;
bool fr_found = false;
+ bool attr_found = false;
do
{
if (gfc_match ("fr ( ") == MATCH_YES)
@@ -1859,99 +1874,129 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
return MATCH_ERROR;
}
fr_found = true;
- gfc_symbol *sym = NULL;
- e = NULL;
- locus loc = gfc_current_locus;
- if (gfc_match_symbol (&sym, 0) != MATCH_YES
- || gfc_match (" _") == MATCH_YES)
+ do
{
- gfc_current_locus = loc;
- if (gfc_match_expr (&e) == MATCH_ERROR)
+ if (gfc_match_expr (&e) != MATCH_YES)
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",
- &loc);
- gfc_free_expr (e);
+ if (e->expr_type != EXPR_CONSTANT
+ || e->ref != NULL
+ || !gfc_resolve_expr (e)
+ || (e->ts.type != BT_INTEGER
+ && e->ts.type != BT_CHARACTER)
+ || (e->ts.type == BT_INTEGER
+ && (!e->symtree
+ || e->symtree->n.sym->attr.flavor != FL_PARAMETER
+ || !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 scalar integer parameter or "
+ "non-empty default-kind character literal "
+ "at %L", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ gfc_gobble_whitespace ();
+ int val;
+ if (e->ts.type == BT_INTEGER)
+ {
+ val = mpz_get_si (e->value.integer);
+ if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier "
+ "%qd at %L", val, &e->where);
+ val = 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", &e->where);
+ return MATCH_ERROR;
+ }
+ val = omp_get_fr_id_from_name (str);
+ if (val == 0)
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qs "
+ "at %L", str, &e->where);
+ }
+ int_list.push_back (val);
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
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';
- }
+ while (true);
}
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)
+ attr_found = true;
+ if (attr_string.empty ())
+ for (int i = 0; i < cnt_brace_grp; ++i)
+ {
+ /* Add dummy elements for previous curly-brace blocks. */
+ attr_string += ' ';
+ attr_string += '\0';
+ attr_string += '\0';
+ }
+ do
{
- gfc_error ("Unexpected null or %<,%> character in "
- "character literal at %L", &e->where);
+ if (gfc_match_expr (&e) != MATCH_YES)
+ return MATCH_ERROR;
+ if (e->expr_type != EXPR_CONSTANT
+ || e->rank != 0
+ || e->ts.type != BT_CHARACTER
+ || e->ts.kind != gfc_default_character_kind)
+ {
+ gfc_error ("Expected default-kind character literal "
+ "at %L", &e->where);
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+ gfc_gobble_whitespace ();
+ 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_string += str;
+ attr_string += '\0';
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ gfc_error ("Expected %<,%> or %<)%> at %C");
return MATCH_ERROR;
}
- attr += str;
- attr += '\0';
+ while (true);
}
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)
@@ -1960,13 +2005,20 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
return MATCH_ERROR;
}
while (true);
+ ++cnt_brace_grp;
if (!fr_found)
+ int_list.push_back (GOMP_INTEROP_IFR_NONE);
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
+ if (!attr_string.empty ())
{
- pref_string += ' ';
- pref_string += '\0';
+ if (!attr_found)
+ {
+ /* Dummy entry. */
+ attr_string += ' ';
+ attr_string += '\0';
+ }
+ attr_string += '\0';
}
- pref_string += attr;
- pref_string += '\0';
if (gfc_match (", ") == MATCH_YES)
continue;
@@ -1982,6 +2034,7 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
if (gfc_match_expr (&e) != MATCH_YES)
return MATCH_ERROR;
if (!gfc_resolve_expr (e)
+ || e->rank != 0
|| e->expr_type != EXPR_CONSTANT
|| (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER)
|| (e->ts.type == BT_INTEGER
@@ -1990,17 +2043,23 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
&& (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_error ("Expected constant scalar integer expression or "
+ "non-empty default-kind character literal at %L", &e->where);
gfc_free_expr (e);
return MATCH_ERROR;
}
+ gfc_gobble_whitespace ();
+ int val;
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 += ' ';
+ val = mpz_get_si (e->value.integer);
+ if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qd at %L",
+ val, &e->where);
+ val = 0;
+ }
}
else
{
@@ -2009,15 +2068,18 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
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);
+ gfc_error ("Unexpected null character in character "
+ "literal at %L", &e->where);
return MATCH_ERROR;
}
- pref_string += str;
+ val = omp_get_fr_id_from_name (str);
+ if (val == 0)
+ gfc_warning (OPT_Wopenmp,
+ "Unknown foreign runtime identifier %qs at %L",
+ str, &e->where);
}
- pref_string += '\0';
- pref_string += '\0';
- ++cnt;
+ int_list.push_back (val);
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
gfc_free_expr (e);
if (gfc_match (", ") == MATCH_YES)
continue;
@@ -2027,19 +2089,16 @@ gfc_match_omp_prefer_type (char **pref_str, int *pref_str_len, int **pref_int_ar
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';
+ int_list.push_back (GOMP_INTEROP_IFR_SEPARATOR);
+ *fr_int_array = XNEWVEC (char, int_list.size ());
+ memcpy (*fr_int_array, int_list.data (), sizeof (char) * int_list.size ());
- *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 ())
+ if (!attr_string.empty ())
{
- *pref_int_array = XNEWVEC (int, cnt);
- memcpy (*pref_int_array, int_list.data (), sizeof (int) * cnt);
+ attr_string += '\0';
+ *attr_str_len = attr_string.length();
+ *attr_str = XNEWVEC (char, attr_string.length ());
+ memcpy (*attr_str, attr_string.data (), attr_string.length ());
}
return MATCH_YES;
}
@@ -2052,21 +2111,21 @@ static match
gfc_match_omp_init (gfc_omp_namelist **list)
{
bool target = false, targetsync = false;
- char *pref_str = NULL;
- int pref_str_len = 0;
- int *pref_int_array = NULL;
+ char *fr_int_array = NULL;
+ char *attr_str = NULL;
+ int attr_str_len = 0;
match m;
locus old_loc = gfc_current_locus;
do {
if (gfc_match ("prefer_type ( ") == MATCH_YES)
{
- if (pref_str)
+ if (fr_int_array)
{
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);
+ m = gfc_match_omp_prefer_type (&fr_int_array, &attr_str,
+ &attr_str_len);
if (m != MATCH_YES)
return m;
if (gfc_match (", ") == MATCH_YES)
@@ -2084,7 +2143,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
if (gfc_match (": ") == MATCH_YES)
break;
gfc_char_t c = gfc_peek_char ();
- if (!pref_str
+ if (!fr_int_array
&& (c == ')'
|| (gfc_current_form != FORM_FREE
&& (c == '_' || ISALPHA (c)))))
@@ -2103,7 +2162,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
if (gfc_match (": ") == MATCH_YES)
break;
gfc_char_t c = gfc_peek_char ();
- if (!pref_str
+ if (!fr_int_array
&& (c == ')'
|| (gfc_current_form != FORM_FREE
&& (c == '_' || ISALPHA (c)))))
@@ -2114,7 +2173,7 @@ gfc_match_omp_init (gfc_omp_namelist **list)
gfc_error ("Expected %<,%> or %<:%> at %C");
return MATCH_ERROR;
}
- if (pref_str)
+ if (fr_int_array)
{
gfc_error ("Expected %<target%> or %<targetsync%> at %C");
return MATCH_ERROR;
@@ -2131,9 +2190,9 @@ gfc_match_omp_init (gfc_omp_namelist **list)
{
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;
+ n->u.init.attr = attr_str;
+ n->u.init.len = attr_str_len;
+ n->u2.init_interop_fr = fr_int_array;
}
return MATCH_YES;
}
diff --git a/gcc/omp-api.h b/gcc/omp-api.h
index 0884e51c61c..1b877f257f0 100644
--- a/gcc/omp-api.h
+++ b/gcc/omp-api.h
@@ -29,4 +29,7 @@ along with GCC; see the file COPYING3. If not see
extern bool omp_runtime_api_procname (const char *name);
extern bool omp_runtime_api_call (const_tree fndecl);
+extern int omp_get_fr_id_from_name (const char *);
+extern const char *omp_get_name_from_fr_id (int);
+
#endif
diff --git a/gcc/omp-general.cc b/gcc/omp-general.cc
index aaa179afe13..de91ba8a4a7 100644
--- a/gcc/omp-general.cc
+++ b/gcc/omp-general.cc
@@ -3385,6 +3385,35 @@ omp_runtime_api_call (const_tree fndecl)
return omp_runtime_api_procname (IDENTIFIER_POINTER (declname));
}
+/* See "Additional Definitions for the OpenMP API Specification" document;
+ associated IDs are 1, 2, ... */
+static const char* omp_interop_fr_str[] = {"cuda", "cuda_driver", "opencl",
+ "sycl", "hip", "level_zero", "hsa"};
+
+/* Returns the foreign-runtime ID if found or 0 otherwise. */
+
+int
+omp_get_fr_id_from_name (const char *str)
+{
+ static_assert (GOMP_INTEROP_IFR_LAST == ARRAY_SIZE (omp_interop_fr_str), "");
+
+ for (unsigned i = 0; i < ARRAY_SIZE (omp_interop_fr_str); ++i)
+ if (!strcmp (str, omp_interop_fr_str[i]))
+ return i + 1;
+ return 0;
+}
+
+/* Returns the string value to a foreign-runtime integer value or NULL if value
+ is not known. */
+
+const char *
+omp_get_name_from_fr_id (int fr_id)
+{
+ if (fr_id < 1 || fr_id > (int) ARRAY_SIZE (omp_interop_fr_str))
+ return NULL;
+ return omp_interop_fr_str[fr_id-1];
+}
+
namespace omp_addr_tokenizer {
/* We scan an expression by recursive descent, and build a vector of
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
index bbb1dea1be6..8c99fc97f88 100644
--- a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
@@ -28,6 +28,8 @@ implicit none
!$omp requires reverse_offload
+integer(omp_interop_fr_kind), parameter :: ifr_array(2) = [omp_ifr_cuda, omp_ifr_hip]
+
integer(omp_interop_kind) :: obj1, obj2, obj3, obj4, obj5
integer :: x
@@ -37,7 +39,7 @@ integer :: x
!$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 interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" }
!$omp end assume
!$omp interop init(prefer_type("cu"//char(0)//"da") : obj3) ! { dg-error "Unexpected null character in character literal" }
@@ -52,11 +54,29 @@ integer :: x
!$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( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" }
+!$omp interop init ( prefer_type( sin(3.3) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4 ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(4_"cuda" ) }) : obj1) ! { dg-error "Expected scalar integer parameter 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
+!$omp interop init ( prefer_type( {fr(1_"cuda" ) }) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero ) }, {fr(omp_ifr_hip)}) : obj1) ! OK
+!$omp interop init ( prefer_type( {fr(omp_ifr_level_zero + 1) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(x) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(ifr_array ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( {fr(ifr_array(1) ) }) : obj1) ! { dg-error "Expected scalar integer parameter or non-empty default-kind character literal" }
+
+!$omp interop init ( prefer_type( omp_ifr_level_zero, omp_ifr_hip ) : obj1) ! OK
+!$omp interop init ( prefer_type( omp_ifr_level_zero +1 ) : obj1) ! OK
+!$omp interop init ( prefer_type( x ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( ifr_array ) : obj1) ! { dg-error "Expected constant scalar integer expression or non-empty default-kind character literal" }
+!$omp interop init ( prefer_type( ifr_array(2) ) : obj1) ! OK
+
+!$omp interop init ( prefer_type( 4, omp_ifr_hip*4) : obj1) ! { dg-warning "Unknown foreign runtime identifier '20'" }
+!$omp interop init ( prefer_type( 4, 1, 3) : obj1)
+
+!$omp interop init ( prefer_type( {fr("cuda","sycl") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } , {fr(omp_ifr_hip) }) : obj1)
+!$omp interop init ( prefer_type( {fr("cuda","sycl"), attr("ompx_1", "ompx_2"), attr("ompx_3") }, {attr("ompx_4", "ompx_5"),fr(omp_ifr_hsa,omp_ifr_level_zero)} ) : obj1)
+!$omp interop init ( prefer_type( { fr("cuda","sycl"), attr("ompx_1") }, {fr(omp_ifr_hsa,omp_ifr_level_zero)} , {attr("ompx_a") } ) : obj1)
end
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90
index c7673a662d0..f3391bf88f0 100644
--- a/gcc/testsuite/gfortran.dg/gomp/interop-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-2.f90
@@ -26,7 +26,7 @@ implicit none
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_"") }) : obj1) ! { dg-error "Expected scalar integer parameter 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_'" }
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90 b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90
index a6d2cc460fb..462ed4f2e4b 100644
--- a/gcc/testsuite/gfortran.dg/gomp/interop-3.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/interop-3.f90
@@ -33,7 +33,7 @@ integer :: x
!$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 interop init(prefer_type("cu"//char(1)//"da") : obj3) ! { dg-warning "Unknown foreign runtime identifier 'cu\\\\x01da'" }
!$omp end assume
!$omp interop init(obj1, obj2, obj1), use(obj4) destroy(obj4)
diff --git a/include/gomp-constants.h b/include/gomp-constants.h
index 775fc4e8f64..0fae337f9d6 100644
--- a/include/gomp-constants.h
+++ b/include/gomp-constants.h
@@ -388,6 +388,11 @@ enum gomp_map_kind
#define GOMP_REQUIRES_REVERSE_OFFLOAD 0x80
#define GOMP_REQUIRES_TARGET_USED 0x200
+/* Interop foreign-runtime data. */
+#define GOMP_INTEROP_IFR_LAST 7
+#define GOMP_INTEROP_IFR_SEPARATOR -1
+#define GOMP_INTEROP_IFR_NONE -2
+
/* HSA specific data structures. */
/* Identifiers of device-specific target arguments. */
