+2019-12-19 Julian Brown <julian@codesourcery.com>
+
+ * gfortran.h (gfc_omp_map_op): Add OMP_MAP_ATTACH, OMP_MAP_DETACH.
+ * openmp.c (gfc_match_omp_variable_list): Add allow_derived parameter.
+ Parse derived-type member accesses if true.
+ (omp_mask2): Add OMP_CLAUSE_ATTACH and OMP_CLAUSE_DETACH.
+ (gfc_match_omp_map_clause): Add allow_derived parameter. Pass to
+ gfc_match_omp_variable_list.
+ (gfc_match_omp_clauses): Support attach and detach. Support derived
+ types for appropriate OpenACC directives.
+ (OACC_PARALLEL_CLAUSES, OACC_SERIAL_CLAUSES, OACC_KERNELS_CLAUSES,
+ OACC_DATA_CLAUSES, OACC_ENTER_DATA_CLAUSES): Add OMP_CLAUSE_ATTACH.
+ (OACC_EXIT_DATA_CLAUSES): Add OMP_CLAUSE_DETACH.
+ (check_symbol_not_pointer): Don't disallow pointer objects of derived
+ type.
+ (resolve_oacc_data_clauses): Don't disallow allocatable derived types.
+ (resolve_omp_clauses): Perform duplicate checking only for non-derived
+ type component accesses (plain variables and arrays or array sections).
+ Support component refs.
+ * trans-expr.c (gfc_conv_component_ref,
+ conv_parent_component_references): Make global.
+ (gfc_maybe_dereference_var): New function, broken out of...
+ (gfc_conv_variable): ...here. Call above function.
+ * trans-openmp.c (gfc_omp_privatize_by_reference): Support component
+ refs.
+ (gfc_trans_omp_array_section): New function, broken out of...
+ (gfc_trans_omp_clauses): ...here. Support component refs/derived
+ types, attach and detach clauses.
+ * trans.h (gfc_conv_component_ref, conv_parent_component_references,
+ gfc_maybe_dereference_var): Add prototypes.
+
2019-12-19 Mark Eggleston <mark.eggleston@codethink.com>
PR fortran/92896
{
OMP_MAP_ALLOC,
OMP_MAP_IF_PRESENT,
+ OMP_MAP_ATTACH,
OMP_MAP_TO,
OMP_MAP_FROM,
OMP_MAP_TOFROM,
OMP_MAP_DELETE,
+ OMP_MAP_DETACH,
OMP_MAP_FORCE_ALLOC,
OMP_MAP_FORCE_TO,
OMP_MAP_FORCE_FROM,
gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
bool allow_common, bool *end_colon = NULL,
gfc_omp_namelist ***headp = NULL,
- bool allow_sections = false)
+ bool allow_sections = false,
+ bool allow_derived = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
case MATCH_YES:
gfc_expr *expr;
expr = NULL;
- if (allow_sections && gfc_peek_ascii_char () == '(')
+ if ((allow_sections && gfc_peek_ascii_char () == '(')
+ || (allow_derived && gfc_peek_ascii_char () == '%'))
{
gfc_current_locus = cur_loc;
m = gfc_match_variable (&expr, 0);
OMP_MASK1_LAST
};
-/* OpenACC 2.0 specific clauses. */
+/* OpenACC 2.0+ specific clauses. */
enum omp_mask2
{
OMP_CLAUSE_ASYNC,
OMP_CLAUSE_TILE,
OMP_CLAUSE_IF_PRESENT,
OMP_CLAUSE_FINALIZE,
+ OMP_CLAUSE_ATTACH,
+ OMP_CLAUSE_DETACH,
/* This must come last. */
OMP_MASK2_LAST
};
static bool
gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
- bool allow_common)
+ bool allow_common, bool allow_derived)
{
gfc_omp_namelist **head = NULL;
- if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true)
+ if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
+ allow_derived)
== MATCH_YES)
{
gfc_omp_namelist *n;
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
+ /* Determine whether we're dealing with an OpenACC directive that permits
+ derived type member accesses. This in particular disallows
+ "!$acc declare" from using such accesses, because it's not clear if/how
+ that should work. */
+ bool allow_derived = (openacc
+ && ((mask & OMP_CLAUSE_ATTACH)
+ || (mask & OMP_CLAUSE_DETACH)
+ || (mask & OMP_CLAUSE_HOST_SELF)));
gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
*cp = NULL;
needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_ATTACH)
+ && gfc_match ("attach ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_ATTACH, false,
+ allow_derived))
+ continue;
break;
case 'c':
if ((mask & OMP_CLAUSE_COLLAPSE)
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TOFROM, true))
+ OMP_MAP_TOFROM, true,
+ allow_derived))
continue;
if (mask & OMP_CLAUSE_COPYIN)
{
{
if (gfc_match ("copyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TO, true))
+ OMP_MAP_TO, true,
+ allow_derived))
continue;
}
else if (gfc_match_omp_variable_list ("copyin (",
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("copyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FROM, true))
+ OMP_MAP_FROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYPRIVATE)
&& gfc_match_omp_variable_list ("copyprivate (",
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_ALLOC, true))
+ OMP_MAP_ALLOC, true, allow_derived))
continue;
break;
case 'd':
if ((mask & OMP_CLAUSE_DELETE)
&& gfc_match ("delete ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_RELEASE, true))
+ OMP_MAP_RELEASE, true,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEPEND)
&& gfc_match ("depend ( ") == MATCH_YES)
else
gfc_current_locus = old_loc;
}
+ if ((mask & OMP_CLAUSE_DETACH)
+ && gfc_match ("detach ( ") == MATCH_YES
+ && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
+ OMP_MAP_DETACH, false,
+ allow_derived))
+ continue;
if ((mask & OMP_CLAUSE_DEVICE)
&& !openacc
&& c->device == NULL
&& openacc
&& gfc_match ("device ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FORCE_TO, true))
+ OMP_MAP_FORCE_TO, true,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEVICEPTR)
&& gfc_match ("deviceptr ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FORCE_DEVICEPTR, false))
+ OMP_MAP_FORCE_DEVICEPTR, false,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
&& gfc_match_omp_variable_list
if ((mask & OMP_CLAUSE_HOST_SELF)
&& gfc_match ("host ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FORCE_FROM, true))
+ OMP_MAP_FORCE_FROM, true,
+ allow_derived))
continue;
break;
case 'i':
if ((mask & OMP_CLAUSE_NO_CREATE)
&& gfc_match ("no_create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_IF_PRESENT, true))
+ OMP_MAP_IF_PRESENT, true,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_NOGROUP)
&& !c->nogroup
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("pcopy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TOFROM, true))
+ OMP_MAP_TOFROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("pcopyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TO, true))
+ OMP_MAP_TO, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("pcopyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FROM, true))
+ OMP_MAP_FROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("pcreate ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_ALLOC, true))
+ OMP_MAP_ALLOC, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_PRESENT)
&& gfc_match ("present ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FORCE_PRESENT, false))
+ OMP_MAP_FORCE_PRESENT, false,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("present_or_copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TOFROM, true))
+ OMP_MAP_TOFROM, true,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match ("present_or_copyin ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_TO, true))
+ OMP_MAP_TO, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_COPYOUT)
&& gfc_match ("present_or_copyout ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FROM, true))
+ OMP_MAP_FROM, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_CREATE)
&& gfc_match ("present_or_create ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_ALLOC, true))
+ OMP_MAP_ALLOC, true, allow_derived))
continue;
if ((mask & OMP_CLAUSE_PRIORITY)
&& c->priority == NULL
if (gfc_match_omp_variable_list (" :",
&c->lists[OMP_LIST_REDUCTION],
- false, NULL, &head,
- openacc) == MATCH_YES)
+ false, NULL, &head, openacc,
+ allow_derived) == MATCH_YES)
{
gfc_omp_namelist *n;
if (rop == OMP_REDUCTION_NONE)
if ((mask & OMP_CLAUSE_HOST_SELF)
&& gfc_match ("self ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
- OMP_MAP_FORCE_FROM, true))
+ OMP_MAP_FORCE_FROM, true,
+ allow_derived))
continue;
if ((mask & OMP_CLAUSE_SEQ)
&& !c->seq
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
| OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
- | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
#define OACC_KERNELS_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
| OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
- | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
#define OACC_SERIAL_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
| OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
| OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
| OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
- | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
+ | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
#define OACC_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
- | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT)
+ | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH)
#define OACC_LOOP_CLAUSES \
(omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
| OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
| OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
#define OACC_ENTER_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
- | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE)
+ | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
#define OACC_EXIT_DATA_CLAUSES \
(omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
- | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE)
+ | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
+ | OMP_CLAUSE_DETACH)
#define OACC_WAIT_CLAUSES \
omp_mask (OMP_CLAUSE_ASYNC)
#define OACC_ROUTINE_CLAUSES \
static void
check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
{
- if (sym->ts.type == BT_DERIVED && sym->attr.pointer)
- gfc_error ("POINTER object %qs of derived type in %s clause at %L",
- sym->name, name, &loc);
if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
sym->name, name, &loc);
static void
resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
{
- if (sym->ts.type == BT_DERIVED && sym->attr.allocatable)
- gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
- sym->name, name, &loc);
if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
&& CLASS_DATA (sym)->attr.allocatable))
&& (list != OMP_LIST_REDUCTION || !openacc))
for (n = omp_clauses->lists[list]; n; n = n->next)
{
- if (n->sym->mark)
- gfc_error ("Symbol %qs present on multiple clauses at %L",
- n->sym->name, &n->where);
- else
- n->sym->mark = 1;
+ bool array_only_p = true;
+ /* Disallow duplicate bare variable references and multiple
+ subarrays of the same array here, but allow multiple components of
+ the same (e.g. derived-type) variable. For the latter, duplicate
+ components are detected elsewhere. */
+ if (openacc && n->expr && n->expr->expr_type == EXPR_VARIABLE)
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type != REF_ARRAY)
+ {
+ array_only_p = false;
+ break;
+ }
+ if (array_only_p)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol %qs present on multiple clauses at %L",
+ n->sym->name, &n->where);
+ else
+ n->sym->mark = 1;
+ }
}
gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
"are allowed on ORDERED directive at %L",
&n->where);
}
+ gfc_ref *array_ref = NULL;
+ bool resolved = false;
if (n->expr)
{
- if (!gfc_resolve_expr (n->expr)
+ array_ref = n->expr->ref;
+ resolved = gfc_resolve_expr (n->expr);
+
+ /* Look through component refs to find last array
+ reference. */
+ if (openacc && resolved)
+ while (array_ref
+ && (array_ref->type == REF_COMPONENT
+ || (array_ref->type == REF_ARRAY
+ && array_ref->next
+ && (array_ref->next->type
+ == REF_COMPONENT))))
+ array_ref = array_ref->next;
+ }
+ if (array_ref
+ || (n->expr
+ && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
+ {
+ if (!resolved
|| n->expr->expr_type != EXPR_VARIABLE
- || n->expr->ref == NULL
- || n->expr->ref->next
- || n->expr->ref->type != REF_ARRAY)
+ || array_ref->next
+ || array_ref->type != REF_ARRAY)
gfc_error ("%qs in %s clause at %L is not a proper "
"array section", n->sym->name, name,
&n->where);
- else if (n->expr->ref->u.ar.codimen)
- gfc_error ("Coarrays not supported in %s clause at %L",
- name, &n->where);
+ else if (gfc_is_coindexed (n->expr))
+ gfc_error ("Entry shall not be coindexed in %s "
+ "clause at %L", name, &n->where);
else
{
int i;
- gfc_array_ref *ar = &n->expr->ref->u.ar;
+ gfc_array_ref *ar = &array_ref->u.ar;
for (i = 0; i < ar->dimen; i++)
if (ar->stride[i])
{
/* Convert a derived type component reference. */
-static void
+void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
/* This function deals with component references to components of the
parent type for derived type extensions. */
-static void
+void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
se->expr = res;
}
+/* Dereference VAR where needed if it is a pointer, reference, etc.
+ according to Fortran semantics. */
+
+tree
+gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
+ bool is_classarray)
+{
+ /* Characters are entirely different from other types, they are treated
+ separately. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Dereference character pointer dummy arguments
+ or results. */
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+ else if (!sym->attr.value)
+ {
+ /* Dereference temporaries for class array dummy arguments. */
+ if (sym->attr.dummy && is_classarray
+ && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
+ {
+ if (!descriptor_only_p)
+ var = GFC_DECL_SAVED_DESCRIPTOR (var);
+
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable)
+ && (sym->ts.type != BT_CLASS
+ || (!CLASS_DATA (sym)->attr.dimension
+ && !(CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference scalar hidden result. */
+ if (flag_f2c && sym->ts.type == BT_COMPLEX
+ && (sym->attr.function || sym->attr.result)
+ && !sym->attr.dimension && !sym->attr.pointer
+ && !sym->attr.always_explicit)
+ var = build_fold_indirect_ref_loc (input_location, var);
+
+ /* Dereference non-character, non-class pointer variables.
+ These must be dummies, results, or scalars. */
+ if (!is_classarray
+ && (sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ && (sym->attr.dummy
+ || sym->attr.function
+ || sym->attr.result
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* Now treat the class array pointer variables accordingly. */
+ else if (sym->ts.type == BT_CLASS
+ && sym->attr.dummy
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && ((CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer))
+ var = build_fold_indirect_ref_loc (input_location, var);
+ /* And the case where a non-dummy, non-result, non-function,
+ non-allotable and non-pointer classarray is present. This case was
+ previously covered by the first if, but with introducing the
+ condition !is_classarray there, that case has to be covered
+ explicitly. */
+ else if (sym->ts.type == BT_CLASS
+ && !sym->attr.dummy
+ && !sym->attr.function
+ && !sym->attr.result
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && (sym->assoc
+ || !CLASS_DATA (sym)->attr.allocatable)
+ && !CLASS_DATA (sym)->attr.class_pointer)
+ var = build_fold_indirect_ref_loc (input_location, var);
+ }
+
+ return var;
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
return;
}
-
- /* Dereference the expression, where needed. Since characters
- are entirely different from other types, they are treated
- separately. */
- if (sym->ts.type == BT_CHARACTER)
- {
- /* Dereference character pointer dummy arguments
- or results. */
- if ((sym->attr.pointer || sym->attr.allocatable)
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- }
- else if (!sym->attr.value)
- {
- /* Dereference temporaries for class array dummy arguments. */
- if (sym->attr.dummy && is_classarray
- && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
- {
- if (!se->descriptor_only)
- se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
-
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
-
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension
- && !(sym->attr.codimension && sym->attr.allocatable)
- && (sym->ts.type != BT_CLASS
- || (!CLASS_DATA (sym)->attr.dimension
- && !(CLASS_DATA (sym)->attr.codimension
- && CLASS_DATA (sym)->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference scalar hidden result. */
- if (flag_f2c && sym->ts.type == BT_COMPLEX
- && (sym->attr.function || sym->attr.result)
- && !sym->attr.dimension && !sym->attr.pointer
- && !sym->attr.always_explicit)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
-
- /* Dereference non-character, non-class pointer variables.
- These must be dummies, results, or scalars. */
- if (!is_classarray
- && (sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym)
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
- && (sym->attr.dummy
- || sym->attr.function
- || sym->attr.result
- || (!sym->attr.dimension
- && (!sym->attr.codimension || !sym->attr.allocatable))))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* Now treat the class array pointer variables accordingly. */
- else if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && ((CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
- || CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer))
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- /* And the case where a non-dummy, non-result, non-function,
- non-allotable and non-pointer classarray is present. This case was
- previously covered by the first if, but with introducing the
- condition !is_classarray there, that case has to be covered
- explicitly. */
- else if (sym->ts.type == BT_CLASS
- && !sym->attr.dummy
- && !sym->attr.function
- && !sym->attr.result
- && (CLASS_DATA (sym)->attr.dimension
- || CLASS_DATA (sym)->attr.codimension)
- && (sym->assoc
- || !CLASS_DATA (sym)->attr.allocatable)
- && !CLASS_DATA (sym)->attr.class_pointer)
- se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
- }
+ /* Dereference the expression, where needed. */
+ se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
+ is_classarray);
ref = expr->ref;
}
if (TREE_CODE (type) == POINTER_TYPE)
{
+ while (TREE_CODE (decl) == COMPONENT_REF)
+ decl = TREE_OPERAND (decl, 1);
+
/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
that have POINTER_TYPE type and aren't scalar pointers, scalar
allocatables, Cray pointees or C pointers are supposed to be
static vec<tree, va_heap, vl_embed> *doacross_steps;
+
+/* Translate an array section or array element. */
+
+static void
+gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n,
+ tree decl, bool element, gomp_map_kind ptr_kind,
+ tree node, tree &node2, tree &node3, tree &node4)
+{
+ gfc_se se;
+ tree ptr, ptr2;
+
+ gfc_init_se (&se, NULL);
+
+ if (element)
+ {
+ gfc_conv_expr_reference (&se, n->expr);
+ gfc_add_block_to_block (block, &se.pre);
+ ptr = se.expr;
+ OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
+ }
+ else
+ {
+ gfc_conv_expr_descriptor (&se, n->expr);
+ ptr = gfc_conv_array_data (se.expr);
+ tree type = TREE_TYPE (se.expr);
+ gfc_add_block_to_block (block, &se.pre);
+ OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr,
+ GFC_TYPE_ARRAY_RANK (type));
+ tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ elemsz = fold_convert (gfc_array_index_type, elemsz);
+ OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ OMP_CLAUSE_SIZE (node), elemsz);
+ }
+ gfc_add_block_to_block (block, &se.post);
+ ptr = fold_convert (build_pointer_type (char_type_node), ptr);
+ OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
+
+ if (POINTER_TYPE_P (TREE_TYPE (decl))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
+ && ptr_kind == GOMP_MAP_POINTER)
+ {
+ node4 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
+ OMP_CLAUSE_DECL (node4) = decl;
+ OMP_CLAUSE_SIZE (node4) = size_int (0);
+ decl = build_fold_indirect_ref (decl);
+ }
+ ptr = fold_convert (sizetype, ptr);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ tree type = TREE_TYPE (decl);
+ ptr2 = gfc_conv_descriptor_data_get (decl);
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
+ OMP_CLAUSE_DECL (node2) = decl;
+ OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
+ node3 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
+ OMP_CLAUSE_DECL (node3)
+ = gfc_conv_descriptor_data_get (decl);
+ if (ptr_kind == GOMP_MAP_ATTACH_DETACH)
+ STRIP_NOPS (OMP_CLAUSE_DECL (node3));
+ }
+ else
+ {
+ if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
+ ptr2 = build_fold_addr_expr (decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
+ ptr2 = decl;
+ }
+ node3 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind);
+ OMP_CLAUSE_DECL (node3) = decl;
+ }
+ ptr2 = fold_convert (sizetype, ptr2);
+ OMP_CLAUSE_SIZE (node3)
+ = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
+}
+
static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
locus where, bool declare_simd = false)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|| GFC_DECL_CRAY_POINTEE (decl)
|| GFC_DESCRIPTOR_TYPE_P
- (TREE_TYPE (TREE_TYPE (decl)))))
+ (TREE_TYPE (TREE_TYPE (decl)))
+ || n->sym->ts.type == BT_DERIVED))
{
tree orig_decl = decl;
node4 = build_omp_clause (input_location,
decl = build_fold_indirect_ref (decl);
}
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+ && n->u.map_op != OMP_MAP_ATTACH
+ && n->u.map_op != OMP_MAP_DETACH)
{
tree type = TREE_TYPE (decl);
tree ptr = gfc_conv_descriptor_data_get (decl);
else
OMP_CLAUSE_DECL (node) = decl;
}
- else
+ else if (n->expr
+ && n->expr->expr_type == EXPR_VARIABLE
+ && n->expr->ref->type == REF_COMPONENT)
{
- tree ptr, ptr2;
+ gfc_ref *lastcomp;
+
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ lastcomp = ref;
+
+ symbol_attribute sym_attr;
+
+ sym_attr = lastcomp->u.c.component->attr;
+
gfc_init_se (&se, NULL);
- if (n->expr->ref->u.ar.type == AR_ELEMENT)
+
+ if (!sym_attr.dimension
+ && lastcomp->u.c.component->ts.type != BT_DERIVED)
{
- gfc_conv_expr_reference (&se, n->expr);
+ /* Last component is a scalar. */
+ gfc_conv_expr (&se, n->expr);
gfc_add_block_to_block (block, &se.pre);
- ptr = se.expr;
- OMP_CLAUSE_SIZE (node)
- = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
+ OMP_CLAUSE_DECL (node) = se.expr;
+ gfc_add_block_to_block (block, &se.post);
+ goto finalize_map_clause;
}
- else
- {
- gfc_conv_expr_descriptor (&se, n->expr);
- ptr = gfc_conv_array_data (se.expr);
- tree type = TREE_TYPE (se.expr);
- gfc_add_block_to_block (block, &se.pre);
- OMP_CLAUSE_SIZE (node)
- = gfc_full_array_size (block, se.expr,
- GFC_TYPE_ARRAY_RANK (type));
- tree elemsz
- = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- elemsz = fold_convert (gfc_array_index_type, elemsz);
- OMP_CLAUSE_SIZE (node)
- = fold_build2 (MULT_EXPR, gfc_array_index_type,
- OMP_CLAUSE_SIZE (node), elemsz);
- }
- gfc_add_block_to_block (block, &se.post);
- ptr = fold_convert (build_pointer_type (char_type_node),
- ptr);
- OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr);
- if (POINTER_TYPE_P (TREE_TYPE (decl))
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
+ se.expr = gfc_maybe_dereference_var (n->sym, decl);
+
+ for (gfc_ref *ref = n->expr->ref;
+ ref && ref != lastcomp->next;
+ ref = ref->next)
{
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (node4) = decl;
- OMP_CLAUSE_SIZE (node4) = size_int (0);
- decl = build_fold_indirect_ref (decl);
+ if (ref->type == REF_COMPONENT)
+ {
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (&se, ref);
+
+ gfc_conv_component_ref (&se, ref);
+ }
+ else
+ sorry ("unhandled derived-type component");
}
- ptr = fold_convert (sizetype, ptr);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+
+ tree inner = se.expr;
+
+ /* Last component is a derived type. */
+ if (lastcomp->u.c.component->ts.type == BT_DERIVED)
{
- tree type = TREE_TYPE (decl);
- ptr2 = gfc_conv_descriptor_data_get (decl);
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
- OMP_CLAUSE_DECL (node2) = decl;
- OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (node3)
- = gfc_conv_descriptor_data_get (decl);
+ if (sym_attr.allocatable || sym_attr.pointer)
+ {
+ tree data = inner;
+ tree size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+
+ OMP_CLAUSE_DECL (node)
+ = build_fold_indirect_ref (data);
+ OMP_CLAUSE_SIZE (node) = size;
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node2,
+ GOMP_MAP_ATTACH_DETACH);
+ OMP_CLAUSE_DECL (node2) = data;
+ OMP_CLAUSE_SIZE (node2) = size_int (0);
+ }
+ else
+ {
+ OMP_CLAUSE_DECL (node) = decl;
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ }
}
- else
+ else if (lastcomp->next
+ && lastcomp->next->type == REF_ARRAY
+ && lastcomp->next->u.ar.type == AR_FULL)
{
- if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
- ptr2 = build_fold_addr_expr (decl);
- else
+ /* Just pass the (auto-dereferenced) decl through for
+ bare attach and detach clauses. */
+ if (n->u.map_op == OMP_MAP_ATTACH
+ || n->u.map_op == OMP_MAP_DETACH)
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl)));
- ptr2 = decl;
+ OMP_CLAUSE_DECL (node) = inner;
+ OMP_CLAUSE_SIZE (node) = size_zero_node;
+ goto finalize_map_clause;
}
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (node3) = decl;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))
+ {
+ tree type = TREE_TYPE (inner);
+ tree ptr = gfc_conv_descriptor_data_get (inner);
+ ptr = build_fold_indirect_ref (ptr);
+ OMP_CLAUSE_DECL (node) = ptr;
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
+ OMP_CLAUSE_DECL (node2) = inner;
+ OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
+ node3 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ OMP_CLAUSE_SET_MAP_KIND (node3,
+ GOMP_MAP_ATTACH_DETACH);
+ OMP_CLAUSE_DECL (node3)
+ = gfc_conv_descriptor_data_get (inner);
+ STRIP_NOPS (OMP_CLAUSE_DECL (node3));
+ OMP_CLAUSE_SIZE (node3) = size_int (0);
+ int rank = GFC_TYPE_ARRAY_RANK (type);
+ OMP_CLAUSE_SIZE (node)
+ = gfc_full_array_size (block, inner, rank);
+ tree elemsz
+ = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ elemsz = fold_convert (gfc_array_index_type, elemsz);
+ OMP_CLAUSE_SIZE (node)
+ = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ OMP_CLAUSE_SIZE (node), elemsz);
+ }
+ else
+ OMP_CLAUSE_DECL (node) = inner;
}
- ptr2 = fold_convert (sizetype, ptr2);
- OMP_CLAUSE_SIZE (node3)
- = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2);
+ else /* An array element or section. */
+ {
+ bool element
+ = (lastcomp->next
+ && lastcomp->next->type == REF_ARRAY
+ && lastcomp->next->u.ar.type == AR_ELEMENT);
+
+ gfc_trans_omp_array_section (block, n, inner, element,
+ GOMP_MAP_ATTACH_DETACH,
+ node, node2, node3, node4);
+ }
+ }
+ else /* An array element or array section. */
+ {
+ bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
+ gfc_trans_omp_array_section (block, n, decl, element,
+ GOMP_MAP_POINTER, node, node2,
+ node3, node4);
}
+
+ finalize_map_clause:
switch (n->u.map_op)
{
case OMP_MAP_ALLOC:
case OMP_MAP_IF_PRESENT:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT);
break;
+ case OMP_MAP_ATTACH:
+ OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH);
+ break;
case OMP_MAP_TO:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO);
break;
case OMP_MAP_DELETE:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE);
break;
+ case OMP_MAP_DETACH:
+ OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH);
+ break;
case OMP_MAP_FORCE_ALLOC:
OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC);
break;
/* Convert a missing, dummy argument into a null or zero. */
void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int);
+/* Lowering of component references. */
+void gfc_conv_component_ref (gfc_se * se, gfc_ref * ref);
+void conv_parent_component_references (gfc_se * se, gfc_ref * ref);
+
+/* Automatically dereference var. */
+tree gfc_maybe_dereference_var (gfc_symbol *, tree, bool desc_only = false,
+ bool is_classarray = false);
+
/* Generate code to allocate a string temporary. */
tree gfc_conv_string_tmp (gfc_se *, tree, tree);
/* Get the string length variable belonging to an expression. */
+2019-12-19 Julian Brown <julian@codesourcery.com>
+
+ * gfortran.dg/goacc/derived-types.f90: New test.
+ * gfortran.dg/goacc/derived-types-2.f90: New test.
+ * gfortran.dg/goacc/derived-types-3.f90: New test.
+ * gfortran.dg/goacc/data-clauses.f95: Adjust for expected errors.
+ * gfortran.dg/goacc/enter-exit-data.f95: Likewise.
+
2019-12-19 Julian Brown <julian@codesourcery.com>
Cesar Philippidis <cesar@codesourcery.com>
!$acc end data
- !$acc parallel copy (tip) ! { dg-error "POINTER" }
+ !$acc parallel copy (tip)
!$acc end parallel
- !$acc parallel copy (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel copy (tia)
!$acc end parallel
!$acc parallel deviceptr (i) copy (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel copyin (tip) ! { dg-error "POINTER" }
+ !$acc parallel copyin (tip)
!$acc end parallel
- !$acc parallel copyin (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel copyin (tia)
!$acc end parallel
!$acc parallel deviceptr (i) copyin (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel copyout (tip) ! { dg-error "POINTER" }
+ !$acc parallel copyout (tip)
!$acc end parallel
- !$acc parallel copyout (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel copyout (tia)
!$acc end parallel
!$acc parallel deviceptr (i) copyout (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel create (tip) ! { dg-error "POINTER" }
+ !$acc parallel create (tip)
!$acc end parallel
- !$acc parallel create (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel create (tia)
!$acc end parallel
!$acc parallel deviceptr (i) create (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc parallel present (tip) ! { dg-error "POINTER" }
!$acc end parallel
- !$acc parallel present (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel present (tia)
!$acc end parallel
!$acc parallel deviceptr (i) present (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end parallel
- !$acc parallel present_or_copy (tip) ! { dg-error "POINTER" }
+ !$acc parallel present_or_copy (tip)
!$acc end parallel
- !$acc parallel present_or_copy (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel present_or_copy (tia)
!$acc end parallel
!$acc parallel deviceptr (i) present_or_copy (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel present_or_copyin (tip) ! { dg-error "POINTER" }
+ !$acc parallel present_or_copyin (tip)
!$acc end parallel
- !$acc parallel present_or_copyin (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel present_or_copyin (tia)
!$acc end parallel
!$acc parallel deviceptr (i) present_or_copyin (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel present_or_copyout (tip) ! { dg-error "POINTER" }
+ !$acc parallel present_or_copyout (tip)
!$acc end parallel
- !$acc parallel present_or_copyout (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel present_or_copyout (tia)
!$acc end parallel
!$acc parallel deviceptr (i) present_or_copyout (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
- !$acc parallel present_or_create (tip) ! { dg-error "POINTER" }
+ !$acc parallel present_or_create (tip)
!$acc end parallel
- !$acc parallel present_or_create (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc parallel present_or_create (tia)
!$acc end parallel
!$acc parallel deviceptr (i) present_or_create (i) ! { dg-error "multiple clauses" }
!$acc end parallel
!$acc end data
end subroutine foo
-end module test
\ No newline at end of file
+end module test
--- /dev/null
+module bar
+ type :: type1
+ real(8), pointer, public :: p(:) => null()
+ end type
+ type :: type2
+ class(type1), pointer :: p => null()
+ end type
+end module
+
+subroutine foo (var)
+ use bar
+ type(type2), intent(inout) :: var
+ !$acc enter data create(var%p%p)
+end subroutine
--- /dev/null
+module bar
+ type :: type1
+ integer :: a(5)
+ integer :: b(5)
+ end type
+end module
+
+subroutine foo
+ use bar
+ type(type1) :: var
+ !$acc enter data copyin(var%a) copyin(var%a) ! { dg-error ".var\.a. appears more than once in map clauses" }
+end subroutine
--- /dev/null
+! Test ACC UPDATE with derived types.
+
+module dt
+ integer, parameter :: n = 10
+ type inner
+ integer :: d(n)
+ end type inner
+ type dtype
+ integer(8) :: a, b, c(n)
+ type(inner) :: in
+ end type dtype
+end module dt
+
+program derived_acc
+ use dt
+
+ implicit none
+ type(dtype):: var
+ integer i
+ !$acc declare create(var)
+ !$acc declare pcopy(var%a) ! { dg-error "Syntax error in OpenMP" }
+
+ !$acc update host(var)
+ !$acc update host(var%a)
+ !$acc update device(var)
+ !$acc update device(var%a)
+ !$acc update self(var)
+ !$acc update self(var%a)
+
+ !$acc enter data copyin(var)
+ !$acc enter data copyin(var%a)
+
+ !$acc exit data copyout(var)
+ !$acc exit data copyout(var%a)
+
+ !$acc data copy(var)
+ !$acc end data
+
+ !$acc data copyout(var%a)
+ !$acc end data
+
+ !$acc parallel loop pcopyout(var)
+ do i = 1, 10
+ end do
+ !$acc end parallel loop
+
+ !$acc parallel loop copyout(var%a)
+ do i = 1, 10
+ end do
+ !$acc end parallel loop
+
+ !$acc parallel pcopy(var)
+ !$acc end parallel
+
+ !$acc parallel pcopy(var%a)
+ do i = 1, 10
+ end do
+ !$acc end parallel
+
+ !$acc kernels pcopyin(var)
+ !$acc end kernels
+
+ !$acc kernels pcopy(var%a)
+ do i = 1, 10
+ end do
+ !$acc end kernels
+
+ !$acc kernels loop pcopyin(var)
+ do i = 1, 10
+ end do
+ !$acc end kernels loop
+
+ !$acc kernels loop pcopy(var%a)
+ do i = 1, 10
+ end do
+ !$acc end kernels loop
+end program derived_acc
!$acc enter data wait (i, 1)
!$acc enter data wait (a) ! { dg-error "INTEGER" }
!$acc enter data wait (b(5:6)) ! { dg-error "INTEGER" }
- !$acc enter data copyin (tip) ! { dg-error "POINTER" }
- !$acc enter data copyin (tia) ! { dg-error "ALLOCATABLE" }
- !$acc enter data create (tip) ! { dg-error "POINTER" }
- !$acc enter data create (tia) ! { dg-error "ALLOCATABLE" }
- !$acc enter data present_or_copyin (tip) ! { dg-error "POINTER" }
- !$acc enter data present_or_copyin (tia) ! { dg-error "ALLOCATABLE" }
- !$acc enter data present_or_create (tip) ! { dg-error "POINTER" }
- !$acc enter data present_or_create (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc enter data copyin (tip)
+ !$acc enter data copyin (tia)
+ !$acc enter data create (tip)
+ !$acc enter data create (tia)
+ !$acc enter data present_or_copyin (tip)
+ !$acc enter data present_or_copyin (tia)
+ !$acc enter data present_or_create (tip)
+ !$acc enter data present_or_create (tia)
!$acc enter data copyin (i) create (i) ! { dg-error "multiple clauses" }
!$acc enter data copyin (i) present_or_copyin (i) ! { dg-error "multiple clauses" }
!$acc enter data create (i) present_or_copyin (i) ! { dg-error "multiple clauses" }
!$acc exit data wait (i, 1)
!$acc exit data wait (a) ! { dg-error "INTEGER" }
!$acc exit data wait (b(5:6)) ! { dg-error "INTEGER" }
- !$acc exit data copyout (tip) ! { dg-error "POINTER" }
- !$acc exit data copyout (tia) ! { dg-error "ALLOCATABLE" }
- !$acc exit data delete (tip) ! { dg-error "POINTER" }
- !$acc exit data delete (tia) ! { dg-error "ALLOCATABLE" }
+ !$acc exit data copyout (tip)
+ !$acc exit data copyout (tia)
+ !$acc exit data delete (tip)
+ !$acc exit data delete (tia)
!$acc exit data copyout (i) delete (i) ! { dg-error "multiple clauses" }
!$acc exit data finalize
!$acc exit data finalize copyout (i)
projects / gcc.git / commitdiff