bool target;
bool targetsync;
} init;
- bool need_device_ptr;
+ struct
+ {
+ bool need_ptr:1;
+ bool need_addr:1;
+ bool range_start:1;
+ bool omp_num_args_plus:1;
+ bool omp_num_args_minus:1;
+ bool error_p:1;
+ } adj_args;
} u;
union
{
enum clause
{
- match,
- adjust_args,
- append_args
+ clause_match,
+ clause_adjust_args,
+ clause_append_args
} ccode;
if (gfc_match ("match") == MATCH_YES)
- ccode = match;
+ ccode = clause_match;
else if (gfc_match ("adjust_args") == MATCH_YES)
{
- ccode = adjust_args;
+ ccode = clause_adjust_args;
adjust_args_loc = gfc_current_locus;
}
else if (gfc_match ("append_args") == MATCH_YES)
{
- ccode = append_args;
+ ccode = clause_append_args;
append_args_loc = gfc_current_locus;
}
else
break;
}
- if (gfc_match (" (") != MATCH_YES)
+ if (gfc_match (" ( ") != MATCH_YES)
{
gfc_error ("expected %<(%> at %C");
return MATCH_ERROR;
}
- if (ccode == match)
+ if (ccode == clause_match)
{
if (has_match)
{
return MATCH_ERROR;
}
}
- else if (ccode == adjust_args)
+ else if (ccode == clause_adjust_args)
{
has_adjust_args = true;
- bool need_device_ptr_p;
- if (gfc_match (" nothing") == MATCH_YES)
- need_device_ptr_p = false;
- else if (gfc_match (" need_device_ptr") == MATCH_YES)
+ bool need_device_ptr_p = false;
+ bool need_device_addr_p = false;
+ if (gfc_match ("nothing ") == MATCH_YES)
+ ;
+ else if (gfc_match ("need_device_ptr ") == MATCH_YES)
need_device_ptr_p = true;
+ else if (gfc_match ("need_device_addr ") == MATCH_YES)
+ need_device_addr_p = true;
else
{
- gfc_error ("expected %<nothing%> or %<need_device_ptr%> at %C");
+ gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
+ "%<need_device_addr%> at %C");
return MATCH_ERROR;
}
- gfc_omp_namelist **head = NULL;
- if (gfc_match_omp_variable_list (" :", &odv->adjust_args_list, false,
- NULL, &head)
- != MATCH_YES)
+ if (gfc_match (": ") != MATCH_YES)
{
- gfc_error ("expected argument list at %C");
+ gfc_error ("expected %<:%> at %C");
return MATCH_ERROR;
}
- if (need_device_ptr_p)
- for (gfc_omp_namelist *n = *head; n != NULL; n = n->next)
- n->u.need_device_ptr = true;
+ gfc_omp_namelist *tail = NULL;
+ bool need_range = false, have_range = false;
+ while (true)
+ {
+ gfc_omp_namelist *p = gfc_get_omp_namelist ();
+ p->where = gfc_current_locus;
+ p->u.adj_args.need_ptr = need_device_ptr_p;
+ p->u.adj_args.need_addr = need_device_addr_p;
+ if (tail)
+ {
+ tail->next = p;
+ tail = tail->next;
+ }
+ else
+ {
+ gfc_omp_namelist **q = &odv->adjust_args_list;
+ if (*q)
+ {
+ for (; (*q)->next; q = &(*q)->next)
+ ;
+ (*q)->next = p;
+ }
+ else
+ *q = p;
+ tail = p;
+ }
+ if (gfc_match (": ") == MATCH_YES)
+ {
+ if (have_range)
+ {
+ gfc_error ("unexpected %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ p->u.adj_args.range_start = have_range = true;
+ need_range = false;
+ continue;
+ }
+ if (have_range && gfc_match (", ") == MATCH_YES)
+ {
+ have_range = false;
+ continue;
+ }
+ if (have_range && gfc_match (") ") == MATCH_YES)
+ break;
+ locus saved_loc = gfc_current_locus;
+
+ /* Without ranges, only arg names or integer literals permitted;
+ handle literals here as gfc_match_expr simplifies the expr. */
+ if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
+ {
+ gfc_gobble_whitespace ();
+ char c = gfc_peek_ascii_char ();
+ if (c != ')' && c != ',' && c != ':')
+ {
+ gfc_free_expr (p->expr);
+ p->expr = NULL;
+ gfc_current_locus = saved_loc;
+ }
+ }
+ if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
+ {
+ if (!have_range)
+ p->u.adj_args.range_start = need_range = true;
+ else
+ need_range = false;
+
+ locus saved_loc2 = gfc_current_locus;
+ gfc_gobble_whitespace ();
+ char c = gfc_peek_ascii_char ();
+ if (c == '+' || c == '-')
+ {
+ if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
+ p->u.adj_args.omp_num_args_plus = true;
+ else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
+ p->u.adj_args.omp_num_args_minus = true;
+ else if (!gfc_error_check ())
+ {
+ gfc_error ("expected constant integer expression "
+ "at %C");
+ p->u.adj_args.error_p = true;
+ return MATCH_ERROR;
+ }
+ p->where = gfc_get_location_range (&saved_loc, 1,
+ &saved_loc, 1,
+ &gfc_current_locus);
+ }
+ else
+ {
+ p->where = gfc_get_location_range (&saved_loc, 1,
+ &saved_loc, 1,
+ &saved_loc2);
+ p->u.adj_args.omp_num_args_plus = true;
+ }
+ }
+ else if (!p->expr)
+ {
+ match m = gfc_match_expr (&p->expr);
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected dummy parameter name, "
+ "%<omp_num_args%> or constant positive integer"
+ " at %C");
+ p->u.adj_args.error_p = true;
+ return MATCH_ERROR;
+ }
+ if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
+ need_range = true; /* Constant expr but not literal. */
+ p->where = p->expr->where;
+ }
+ else
+ p->where = p->expr->where;
+ gfc_gobble_whitespace ();
+ match m = gfc_match (": ");
+ if (need_range && m != MATCH_YES)
+ {
+ gfc_error ("expected %<:%> at %C");
+ return MATCH_ERROR;
+ }
+ if (m == MATCH_YES)
+ {
+ p->u.adj_args.range_start = have_range = true;
+ need_range = false;
+ continue;
+ }
+ need_range = have_range = false;
+ if (gfc_match (", ") == MATCH_YES)
+ continue;
+ if (gfc_match (") ") == MATCH_YES)
+ break;
+ }
}
- else if (ccode == append_args)
+ else if (ccode == clause_append_args)
{
if (has_append_args)
{
gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
"procedure pointer",
&code->loc);
-
- gfc_omp_declare_variant *odv = gfc_current_ns->omp_declare_variant;
- if (odv != NULL)
- for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
- if (n->sym->ts.type != BT_DERIVED || !n->sym->ts.u.derived->ts.is_iso_c
- || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR))
- {
- gfc_error (
- "argument list item %qs in %<need_device_ptr%> at %L must be of "
- "TYPE(C_PTR)",
- n->sym->name, &n->where);
- }
}
/* Resolve OpenMP directive clauses and check various requirements
}
gfc_omp_declare_variant *odv;
+ gfc_omp_namelist *range_begin = NULL;
for (odv = ns->omp_declare_variant; odv; odv = odv->next)
for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
- if (n->u.need_device_ptr
- && (!gfc_resolve_expr (n->expr) || n->sym->ts.type != BT_DERIVED
- || !n->sym->ts.u.derived->ts.is_iso_c
- || (n->sym->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)))
- {
- gfc_error (
- "argument list item %qs in %<need_device_ptr%> at %L must be of "
- "TYPE(C_PTR)",
- n->sym->name, &n->where);
- }
+ {
+ if ((n->expr == NULL
+ && (range_begin
+ || n->u.adj_args.range_start
+ || n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus))
+ || n->u.adj_args.error_p)
+ {
+ }
+ else if (range_begin
+ || n->u.adj_args.range_start
+ || n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ {
+ if (!n->expr
+ || !gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_CONSTANT
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->rank != 0
+ || mpz_sgn (n->expr->value.integer) < 0
+ || ((n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ && mpz_sgn (n->expr->value.integer) == 0))
+ {
+ if (n->u.adj_args.omp_num_args_plus
+ || n->u.adj_args.omp_num_args_minus)
+ gfc_error ("Expected constant non-negative scalar integer "
+ "offset expression at %L", &n->where);
+ else
+ gfc_error ("For range-based %<adjust_args%>, a constant "
+ "positive scalar integer expression is required "
+ "at %L", &n->where);
+ }
+ }
+ else if (n->expr
+ && n->expr->expr_type == EXPR_CONSTANT
+ && n->expr->ts.type == BT_INTEGER
+ && mpz_sgn (n->expr->value.integer) > 0)
+ {
+ }
+ else if (!n->expr
+ || !gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_VARIABLE)
+ gfc_error ("Expected dummy parameter name or a positive integer "
+ "at %L", &n->where);
+ else if (n->expr->expr_type == EXPR_VARIABLE)
+ n->sym = n->expr->symtree->n.sym;
+
+ range_begin = n->u.adj_args.range_start ? n : NULL;
+ }
}
struct omp_udr_callback_data
}
}
+static void
+gfc_handle_omp_declare_variant (gfc_symbol * sym)
+{
+ if (sym->attr.external
+ && sym->formal_ns
+ && sym->formal_ns->omp_declare_variant)
+ {
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_current_ns = sym->ns;
+ gfc_get_symbol_decl (sym);
+ gfc_current_ns = ns;
+ }
+}
/* Generate all the required code for module variables. */
if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
generate_coarray_init (ns);
+ /* For OpenMP, ensure that declare variant in INTERFACE is is processed
+ especially as some late diagnostic is only done on tree level. */
+ if (flag_openmp)
+ gfc_traverse_ns (ns, gfc_handle_omp_declare_variant);
+
cur_module = NULL;
gfc_trans_use_stmts (ns);
gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
}
+ /* For OpenMP, ensure that declare variant in INTERFACE is is processed
+ especially as some late diagnostic is only done on tree level. */
+ if (flag_openmp)
+ gfc_traverse_ns (ns, gfc_handle_omp_declare_variant);
+
gfc_generate_contained_functions (ns);
has_coarray_vars_or_accessors = caf_accessor_head != NULL;
NULL_TREE, false))
{
tree need_device_ptr_list = NULL_TREE;
+ tree need_device_addr_list = NULL_TREE;
tree append_args_tree = NULL_TREE;
tree id = get_identifier ("omp declare variant base");
tree variant = gfc_get_symbol_decl (variant_proc_sym);
if (ns->proc_name->ts.type == BT_CHARACTER)
arg_idx_offset++;
}
+ int nargs = 0;
+ for (gfc_formal_arglist *arg
+ = gfc_sym_get_dummy_args (ns->proc_name);
+ arg; arg = arg->next)
+ nargs++;
if (odv->append_args_list)
{
- int append_arg_no = arg_idx_offset;
- gfc_formal_arglist *arg;
- for (arg = gfc_sym_get_dummy_args (ns->proc_name); arg;
- arg = arg->next)
- append_arg_no++;
+ int append_arg_no = arg_idx_offset + nargs;
tree last_arg = NULL_TREE;
for (gfc_omp_namelist *n = odv->append_args_list;
n != NULL; n = n->next)
else
append_args_tree = last_arg = t;
}
- /* Store as (purpose = arg number to be used for inserting
- and value = list of interop items. */
+ /* Store as 'purpose' = arg number to be used for inserting
+ and 'value' = list of interop items. */
append_args_tree = build_tree_list (
build_int_cst (integer_type_node,
append_arg_no),
append_args_tree);
}
-
- if (odv->adjust_args_list)
- need_device_ptr_list = make_node (TREE_LIST);
vec<gfc_symbol *> adjust_args_list = vNULL;
for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
arg_list != NULL; arg_list = arg_list->next)
{
- if (!arg_list->sym->attr.dummy)
+ int from, to;
+ if (arg_list->expr == NULL || arg_list->sym)
+ from = ((arg_list->u.adj_args.omp_num_args_minus
+ || arg_list->u.adj_args.omp_num_args_plus)
+ ? nargs : 1);
+ else
{
- gfc_error (
- "list item %qs at %L is not a dummy argument",
- arg_list->sym->name, &arg_list->where);
- continue;
+ if (arg_list->u.adj_args.omp_num_args_plus)
+ mpz_add_ui (arg_list->expr->value.integer,
+ arg_list->expr->value.integer, nargs);
+ if (arg_list->u.adj_args.omp_num_args_minus)
+ mpz_ui_sub (arg_list->expr->value.integer, nargs,
+ arg_list->expr->value.integer);
+ if (mpz_sgn (arg_list->expr->value.integer) <= 0)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Expected positive argument index "
+ "at %L", &arg_list->where);
+ from = 1;
+ }
+ else
+ from
+ = (mpz_fits_sint_p (arg_list->expr->value.integer)
+ ? mpz_get_si (arg_list->expr->value.integer)
+ : INT_MAX);
+ if (from > nargs)
+ gfc_warning (OPT_Wopenmp,
+ "Argument index at %L exceeds number "
+ "of arguments %d", &arg_list->where,
+ nargs);
}
- if (adjust_args_list.contains (arg_list->sym))
+ locus loc = arg_list->where;
+ if (!arg_list->u.adj_args.range_start)
+ to = from;
+ else
{
- gfc_error ("%qs at %L is specified more than once",
- arg_list->sym->name, &arg_list->where);
- continue;
+ loc = gfc_get_location_range (&arg_list->where, 0,
+ &arg_list->where, 0,
+ &arg_list->next->where);
+ if (arg_list->next->expr == NULL)
+ to = nargs;
+ else
+ {
+ if (arg_list->next->u.adj_args.omp_num_args_plus)
+ mpz_add_ui (arg_list->next->expr->value.integer,
+ arg_list->next->expr->value.integer,
+ nargs);
+ if (arg_list->next->u.adj_args.omp_num_args_minus)
+ mpz_ui_sub (arg_list->next->expr->value.integer,
+ nargs,
+ arg_list->next->expr->value.integer);
+ if (mpz_sgn (arg_list->next->expr->value.integer)
+ <= 0)
+ {
+ gfc_warning (OPT_Wopenmp,
+ "Expected positive argument "
+ "index at %L", &loc);
+ to = 0;
+ }
+ else
+ to = mpz_get_si (
+ arg_list->next->expr->value.integer);
+ }
+ if (from > to && to != 0)
+ gfc_warning (OPT_Wopenmp,
+ "Upper argument index smaller than "
+ "lower one at %L", &loc);
+ if (to > nargs)
+ to = nargs;
+ arg_list = arg_list->next;
}
- adjust_args_list.safe_push (arg_list->sym);
- if (arg_list->u.need_device_ptr)
+ if (from > nargs)
+ continue;
+ /* Change to zero based index. */
+ from--; to--;
+ gfc_formal_arglist *arg = ns->proc_name->formal;
+ if (!arg_list->sym && to >= from)
+ for (int idx = 0; idx < from; idx++)
+ arg = arg->next;
+ for (int idx = from; idx <= to; idx++)
{
- int idx;
- gfc_formal_arglist *arg;
- for (arg = ns->proc_name->formal, idx = 0;
- arg != NULL; arg = arg->next, idx++)
- if (arg->sym == arg_list->sym)
- break;
- gcc_assert (arg != NULL);
- // Store 0-based argument index,
- // as in gimplify_call_expr
- need_device_ptr_list = chainon (
- need_device_ptr_list,
- build_tree_list (
- NULL_TREE,
- build_int_cst (
- integer_type_node,
- idx + arg_idx_offset)));
+ if (idx > from)
+ arg = arg->next;
+ if (arg_list->sym)
+ {
+ for (arg = ns->proc_name->formal, idx = 0;
+ arg != NULL; arg = arg->next, idx++)
+ if (arg->sym == arg_list->sym)
+ break;
+ if (!arg || !arg_list->sym->attr.dummy)
+ {
+ gfc_error ("List item %qs at %L, declared at "
+ "%L, is not a dummy argument",
+ arg_list->sym->name, &loc,
+ &arg_list->sym->declared_at);
+ continue;
+ }
+ }
+ if (arg_list->u.adj_args.need_ptr
+ && (arg->sym->ts.f90_type != BT_VOID
+ || !arg->sym->ts.u.derived->ts.is_iso_c
+ || (arg->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)
+ || arg->sym->attr.dimension))
+ {
+ gfc_error ("Argument %qs at %L to list item in "
+ "%<need_device_ptr%> at %L must be a "
+ "scalar of TYPE(C_PTR)",
+ arg->sym->name,
+ &arg->sym->declared_at, &loc);
+ if (!arg->sym->attr.value)
+ inform (gfc_get_location (&loc),
+ "Consider using %<need_device_addr%> "
+ "instead");
+ continue;
+ }
+ if (arg_list->u.adj_args.need_addr
+ && arg->sym->attr.value)
+ {
+ gfc_error ("Argument %qs at %L to list item in "
+ "%<need_device_addr%> at %L must not "
+ "have the VALUE attribute",
+ arg->sym->name,
+ &arg->sym->declared_at, &loc);
+ continue;
+ }
+ if (adjust_args_list.contains (arg->sym))
+ {
+ gfc_error ("%qs at %L is specified more than "
+ "once", arg->sym->name, &loc);
+ continue;
+ }
+ adjust_args_list.safe_push (arg->sym);
+
+ if (arg_list->u.adj_args.need_addr)
+ {
+ /* TODO: Has to to support OPTIONAL and array
+ descriptors; should check for CLASS, coarrays?
+ Reject "abc" and 123 as actual arguments (in
+ gimplify.cc or in the FE? Reject noncontiguous
+ actuals? Cf. also PR C++/118859.
+ Also check array-valued type(c_ptr). */
+ static bool warned = false;
+ if (!warned)
+ sorry_at (gfc_get_location (&loc),
+ "%<need_device_addr%> not yet "
+ "supported");
+ warned = true;
+ continue;
+ }
+ if (arg_list->u.adj_args.need_ptr
+ || arg_list->u.adj_args.need_addr)
+ {
+ // Store 0-based argument index,
+ // as in gimplify_call_expr
+ tree t
+ = build_tree_list (
+ NULL_TREE,
+ build_int_cst (integer_type_node,
+ idx + arg_idx_offset));
+ if (arg_list->u.adj_args.need_ptr)
+ need_device_ptr_list
+ = chainon (need_device_ptr_list, t);
+ else
+ need_device_addr_list
+ = chainon (need_device_addr_list, t);
+ }
}
}
tree t = NULL_TREE;
- if (need_device_ptr_list || append_args_tree)
+ if (need_device_ptr_list
+ || need_device_addr_list
+ || append_args_tree)
{
t = build_tree_list (need_device_ptr_list,
- NULL_TREE /*need_device_addr */),
+ need_device_addr_list),
TREE_CHAIN (t) = append_args_tree;
DECL_ATTRIBUTES (variant) = tree_cons (
get_identifier ("omp declare variant variant args"), t,
integer function f3 (a)
import c_ptr
type(c_ptr), intent(inout) :: a
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (other: a) ! { dg-error "expected 'nothing', 'need_device_ptr' or 'need_device_addr' at .1." }
end function
integer function f4 (a)
import c_ptr
end function
integer function f5 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing' or 'need_device_ptr' at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args () ! { dg-error "expected 'nothing', 'need_device_ptr' or 'need_device_addr' at .1." }
end function
integer function f6 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected argument list at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing) ! { dg-error "expected ':' at .1." }
end function
integer function f7 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected argument list at .1." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing:) ! { dg-error "expected dummy parameter name, 'omp_num_args' or constant positive integer at .1." }
end function
end interface
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f), match (construct={dispatch}) , &
!$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c)
end function
end subroutine
end module
+
+module other
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function g(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function g0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (g), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end module
+
+subroutine foobar
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function h(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function h0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (h), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end
+
+
+subroutine outer
+contains
+subroutine inner
+ use iso_c_binding, only: c_ptr
+ implicit none
+
+ interface
+ integer function st(a, b, c)
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ end function
+ integer function st0(a, b, c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+ import c_ptr
+ integer, intent(in) :: a
+ type(c_ptr), intent(inout) :: b
+ type(c_ptr), intent(out) :: c(:)
+ !$omp declare variant (st), match (construct={dispatch}) , &
+ !$omp& adjust_args (nothing: a) ,adjust_args (need_device_ptr: b),adjust_args (need_device_ptr: c) ! { dg-error "Argument 'c' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } .-1 }
+ end function
+ end interface
+end subroutine inner
+end subroutine outer
--- /dev/null
+! This failed with a bogus:
+! 'must be of TYPE(C_PTR)'
+module m
+ implicit none
+contains
+ subroutine q()
+ end
+ subroutine one(x)
+ integer :: x
+ end
+ subroutine two(x)
+ !$omp declare variant(one) match(construct={dispatch}) adjust_args(nothing: x)
+ integer :: x
+
+ !$omp dispatch
+ call q
+ end
+end
--- /dev/null
+module m
+ implicit none
+contains
+ subroutine f(x,y,z)
+ integer:: x, y, z
+ value :: y
+ end subroutine
+ subroutine f0(x,y,z)
+ !$omp declare variant(f) adjust_args ( need_device_addr : : omp_num_args-1) &
+ !$omp& adjust_args ( need_device_ptr : z) &
+ !$omp& match ( construct = { dispatch } )
+ integer:: x, y, z
+ value :: y
+
+! { dg-error "19: Argument 'y' at .1. to list item in 'need_device_addr' at .2. must not have the VALUE attribute" "" { target *-*-* } 8 }
+! { dg-error "62: Argument 'y' at .1. to list item in 'need_device_addr' at .2. must not have the VALUE attribute" "" { target *-*-* } 9 }
+! { dg-message "sorry, unimplemented: 'need_device_addr' not yet supported" "" { target *-*-* } 9 }
+
+! { dg-error "Argument 'z' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" "" { target *-*-* } 8 }
+! { dg-error "Argument 'z' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" "" { target *-*-* } 10 }
+! { dg-note "Consider using 'need_device_addr' instead" "" { target *-*-* } 10 }
+ end subroutine
+end module m
+
+module m2
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_ptr : : ) &
+ !$omp& adjust_args ( nothing : 2, 4) &
+ !$omp& match ( construct = { dispatch } )
+
+! { dg-error "54: 'y' at .1. is specified more than once" "" { target *-*-* } 37 }
+! { dg-warning "57: Argument index at .1. exceeds number of arguments 3 \\\[-Wopenmp\\\]" "" { target *-*-* } 37 }
+ end subroutine
+ end interface
+end module m2
+
+module m3
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : omp_num_args -4 :, 3 : 2) &
+ !$omp& match ( construct = { dispatch } )
+! { dg-warning "63: Expected positive argument index at .1. \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "82: Upper argument index smaller than lower one at .1. \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+ end subroutine
+ end interface
+end module m3
+
+module m4
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : x, y, omp_num_args -2 : omp_num_args -1) &
+ !$omp& adjust_args ( need_device_addr : z) &
+ !$omp& adjust_args ( need_device_addr : omp_num_args : 3) &
+ !$omp& match ( construct = { dispatch } )
+! { dg-error "69: 'x' at .1. is specified more than once" "" { target *-*-* } .-4 }
+! { dg-error "69: 'y' at .1. is specified more than once" "" { target *-*-* } .-5 }
+! { dg-error "63: 'z' at .1. is specified more than once" "" { target *-*-* } .-4 }
+ end subroutine
+ end interface
+end module m4
--- /dev/null
+module m3
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : -1 : omp_num_args + 10 ) & ! { dg-error "64: For range-based 'adjust_args', a constant positive scalar integer expression is required" }
+ !$omp& adjust_args ( nothing : 1+1) & ! { dg-error "expected ':'" }
+ !$omp& match ( construct = { dispatch } )
+ end subroutine
+ end interface
+end module m3
+
+module m4
+ use iso_c_binding, only: c_ptr
+ implicit none
+ interface
+ subroutine f(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ end subroutine
+ subroutine f0(x,y,z)
+ import
+ type(c_ptr) :: x, y, z
+ !$omp declare variant(f) adjust_args ( need_device_addr : 3.3 ) & ! { dg-error "Expected dummy parameter name or a positive integer" }
+ !$omp& adjust_args ( nothing : 1 : y ) & ! { dg-error "For range-based 'adjust_args', a constant positive scalar integer expression is required" }
+ !$omp& match ( construct = { dispatch } )
+ end subroutine
+ end interface
+end module m4
subroutine f3 (i)
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (nothing: z) ! { dg-error "Symbol 'z' at .1. has no IMPLICIT type" }
+! { dg-error "Expected dummy parameter name or a positive integer at .1." "" { target *-*-* } .-1 }
end subroutine
end module
end interface
contains
- subroutine f9 (i)
+ subroutine f9 (i) ! { dg-error "Argument 'i' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
integer, intent(inout) :: i
- !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: i) ! { dg-error "argument list item 'i' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." }
+ !$omp declare variant (f1) match (construct={dispatch}) adjust_args (need_device_ptr: i) ! { dg-error "Argument 'i' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
end subroutine
- subroutine f13 (a)
+ subroutine f13 (a) ! { dg-error "Argument 'a' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
type(c_funptr), intent(inout) :: a
- !$omp declare variant (h) match (construct={dispatch}) adjust_args (need_device_ptr: a) ! { dg-error "argument list item 'a' in 'need_device_ptr' at .1. must be of TYPE.C_PTR." }
+ !$omp declare variant (h) match (construct={dispatch}) adjust_args (need_device_ptr: a) ! { dg-error "Argument 'a' at .1. to list item in 'need_device_ptr' at .2. must be a scalar of TYPE\\(C_PTR\\)" }
end subroutine
subroutine test
module main
use iso_c_binding, only: c_ptr
implicit none
- type(c_ptr) :: b
+ type(c_ptr) :: b ! { dg-error "List item 'b' at .1., declared at .2., is not a dummy argument" }
contains
subroutine base2 (a)
end subroutine
subroutine base4 (a)
type(c_ptr), intent(inout) :: a
- !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: b) ! { dg-error "list item 'b' at .1. is not a dummy argument" }
+ !$omp declare variant (variant2) match (construct={dispatch}) adjust_args (need_device_ptr: b) ! { dg-error "List item 'b' at .1., declared at .2., is not a dummy argument" }
end subroutine
subroutine variant2 (a)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c)
end function
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c)
end function
end module
! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } }
-! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(c, D\.\[0-9]+\\);" 2 "gimple" } }
! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
end function
integer function f0(a, b, c)
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b, c)
end function
import c_ptr
integer, intent(in) :: a
type(c_ptr), intent(inout) :: b
- type(c_ptr), intent(out) :: c(:)
+ type(c_ptr), intent(out) :: c
!$omp declare variant (f) match (construct={dispatch}) &
!$omp& adjust_args (nothing: a) adjust_args (need_device_ptr: b) adjust_args (need_device_ptr: c)
end function
end module
! { dg-final { scan-tree-dump-times "__builtin_omp_get_default_device \\(\\);" 2 "gimple" } }
-! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(parm\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(c, D\.\[0-9]+\\);" 2 "gimple" } }
! { dg-final { scan-tree-dump-times "D\.\[0-9]+ = __builtin_omp_get_mapped_ptr \\(b\.\[0-9]+, D\.\[0-9]+\\);" 2 "gimple" } }
--- /dev/null
+! { dg-additional-options "-fdump-tree-gimple" }
+! { dg-final { scan-tree-dump-not "g \\(\\)" "gimple" } }
+! { dg-final { scan-tree-dump "i = f \\(\\);" "gimple" } }
+
+! PR fortran/115271
+
+module m
+interface
+ integer function f ()
+ end
+ integer function g ()
+ !$omp declare variant(f) match(construct={dispatch})
+ end
+end interface
+end
+
+use m
+!$omp dispatch
+ i = g()
+end
projects / thirdparty / gcc.git / commitdiff
