https://gcc.gnu.org/g:2b5d2e573171bf51ca902045ce3e5be654ea3d37
commit 2b5d2e573171bf51ca902045ce3e5be654ea3d37
Author: Tobias Burnus <tbur...@baylibre.com>
Date: Thu Jan 23 22:31:42 2025 +0100
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.
(cherry picked from commit 99988464fc86354f0359c0fd91eee444fb5bd8a2)
Diff:
---
gcc/ChangeLog.omp | 11 +
gcc/fortran/ChangeLog.omp | 14 ++
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/ChangeLog.omp | 10 +
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/ChangeLog.omp | 9 +
include/gomp-constants.h | 5 +
14 files changed, 358 insertions(+), 162 deletions(-)
diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp
index 5591b79d60e6..73eb15105039 100644
--- a/gcc/ChangeLog.omp
+++ b/gcc/ChangeLog.omp
@@ -1,3 +1,14 @@
+2025-01-23 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2024-09-13 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/116661
+ * 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.
+
2025-01-23 Tobias Burnus <tbur...@baylibre.com>
Backported from master:
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 0d353d55957d..89cc5f52ebb6 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,17 @@
+2025-01-23 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2024-09-13 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/116661
+ * 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.
+
2025-01-23 Tobias Burnus <tbur...@baylibre.com>
Backported from master:
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 595f9c3c7c12..f09fb4eb6abc 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;
@@ -1533,35 +1535,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 ed23818ea374..34dcb4e44c7b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1392,7 +1392,7 @@ typedef struct gfc_omp_namelist
bool present_modifier;
struct
{
- char *str;
+ char *attr;
int len;
bool target;
bool targetsync;
@@ -1406,7 +1406,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 859cdfc727ba..3ae0f72a00ad 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5548,7 +5548,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
bool free_init = (list == OMP_LIST_INIT);
gfc_omp_namelist *n;
gfc_expr *last_allocator = NULL;
- char *last_init_str = NULL;
+ char *last_init_attr = NULL;
for (; name; name = n)
{
@@ -5572,11 +5572,11 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
{ } /* 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 (free_mapper && name->u2.udm)
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 89d64c36df3a..6567e0269a2e 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -1910,16 +1910,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
@@ -1929,8 +1944,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)
@@ -1942,99 +1957,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)
@@ -2043,13 +2088,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;
@@ -2065,6 +2117,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
@@ -2073,17 +2126,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
{
@@ -2092,15 +2151,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;
@@ -2110,19 +2172,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;
}
@@ -2135,21 +2194,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)
@@ -2167,7 +2226,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)))))
@@ -2186,7 +2245,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)))))
@@ -2197,7 +2256,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;
@@ -2214,9 +2273,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 0884e51c61cb..1b877f257f09 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 fadea54443db..0b17fda64100 100644
--- a/gcc/omp-general.cc
+++ b/gcc/omp-general.cc
@@ -3556,6 +3556,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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 0f0bacf153e8..b3f5731d5119 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,13 @@
+2025-01-23 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2024-09-13 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/116661
+ * 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.
+
2025-01-23 Tobias Burnus <tbur...@baylibre.com>
Backported from master:
diff --git a/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
b/gcc/testsuite/gfortran.dg/gomp/interop-1.f90
index bbb1dea1be62..8c99fc97f888 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 c7673a662d0c..f3391bf88f0b 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 a6d2cc460fb0..462ed4f2e4bc 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/ChangeLog.omp b/include/ChangeLog.omp
index 88098aeb89b2..cb1bc7e6e406 100644
--- a/include/ChangeLog.omp
+++ b/include/ChangeLog.omp
@@ -1,3 +1,12 @@
+2025-01-23 Tobias Burnus <tbur...@baylibre.com>
+
+ Backported from master:
+ 2024-09-13 Tobias Burnus <tbur...@baylibre.com>
+
+ PR fortran/116661
+ * gomp-constants.h (GOMP_INTEROP_IFR_LAST,
+ GOMP_INTEROP_IFR_SEPARATOR, GOMP_INTEROP_IFR_NONE): New.
+
2024-05-04 Sandra Loosemore <sloosem...@baylibre.com>
* cuda/cuda.h (CUdevice_attribute): Add definitions for
diff --git a/include/gomp-constants.h b/include/gomp-constants.h
index 795c22c97fbb..3266de04e4f0 100644
--- a/include/gomp-constants.h
+++ b/include/gomp-constants.h
@@ -430,6 +430,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. */
