#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;
}
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");
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
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)
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)
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;
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
&& (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
{
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;
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;
}
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)
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)))))
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)))))
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;
{
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;
}
!$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
!$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" }
!$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
projects / thirdparty / gcc.git / commitdiff
