#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_DTOR
#undef LANG_HOOKS_OMP_FINISH_CLAUSE
+#undef LANG_HOOKS_OMP_DEEP_MAPPING
+#undef LANG_HOOKS_OMP_DEEP_MAPPING_P
+#undef LANG_HOOKS_OMP_DEEP_MAPPING_CNT
#undef LANG_HOOKS_OMP_ALLOCATABLE_P
#undef LANG_HOOKS_OMP_SCALAR_TARGET_P
#undef LANG_HOOKS_OMP_SCALAR_P
#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor
#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor
#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause
+#define LANG_HOOKS_OMP_DEEP_MAPPING gfc_omp_deep_mapping
+#define LANG_HOOKS_OMP_DEEP_MAPPING_P gfc_omp_deep_mapping_p
+#define LANG_HOOKS_OMP_DEEP_MAPPING_CNT gfc_omp_deep_mapping_cnt
#define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p
#define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p
#define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p
{
gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
p->sym = n->sym;
- p->where = p->where;
+ p->where = n->where;
p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
tl = &c->lists[OMP_LIST_MAP];
&& n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, &n->where);
- if (!openacc
- && list == OMP_LIST_MAP
- && n->sym->ts.type == BT_DERIVED
- && n->sym->ts.u.derived->attr.alloc_comp)
- gfc_error ("List item %qs with allocatable components is not "
- "permitted in map clause at %L", n->sym->name,
- &n->where);
- if (!openacc
- && (list == OMP_LIST_MAP
- || list == OMP_LIST_FROM
- || list == OMP_LIST_TO)
- && ((n->expr && n->expr->ts.type == BT_CLASS)
- || (!n->expr && n->sym->ts.type == BT_CLASS)))
- gfc_warning (OPT_Wopenmp,
- "Mapping polymorphic list item at %L is "
- "unspecified behavior", &n->where);
if (list == OMP_LIST_MAP && !openacc)
switch (code->op)
{
n->sym->name, name, &n->where);
if (!openacc
- && list == OMP_LIST_FIRSTPRIVATE
- && ((n->expr && n->expr->ts.type == BT_CLASS)
- || (!n->expr && n->sym->ts.type == BT_CLASS)))
+ && (list == OMP_LIST_PRIVATE
+ || list == OMP_LIST_FIRSTPRIVATE)
+ && ((n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ || n->sym->ts.type == BT_CLASS))
switch (code->op)
{
case EXEC_OMP_TARGET:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
case EXEC_OMP_TARGET_TEAMS_LOOP:
- gfc_warning (OPT_Wopenmp,
- "FIRSTPRIVATE with polymorphic list item at "
- "%L is unspecified behavior", &n->where);
+ if (n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ gfc_error ("Sorry, list item %qs at %L with allocatable"
+ " components is not yet supported in %s "
+ "clause", n->sym->name, &n->where,
+ list == OMP_LIST_PRIVATE ? "PRIVATE"
+ : "FIRSTPRIVATE");
+ else
+ gfc_error ("Polymorphic list item %qs at %L in %s "
+ "clause has unspecified behavior and "
+ "unsupported", n->sym->name, &n->where,
+ list == OMP_LIST_PRIVATE ? "PRIVATE"
+ : "FIRSTPRIVATE");
break;
default:
break;
n = gfc_get_omp_namelist ();
n->sym = sym;
+ n->where = sym->declared_at;
n->u.map.op = map_op;
if (!module_oacc_clauses)
#include "options.h"
#include "tree.h"
#include "gfortran.h"
+#include "basic-block.h"
+#include "tree-ssa.h"
+#include "function.h"
+#include "gimple.h"
#include "gimple-expr.h"
#include "trans.h"
#include "stringpool.h"
#include "omp-low.h"
#include "memmodel.h" /* For MEMMODEL_ enums. */
#include "dependency.h"
+#include "gimple-iterator.h" /* For gsi_iterator_update. */
+#include "gimplify-me.h" /* For force_gimple_operand. */
#undef GCC_DIAG_STYLE
#define GCC_DIAG_STYLE __gcc_tdiag__
return decl;
}
-/* Return true if TYPE has any allocatable components. */
+/* Return true if TYPE has any allocatable components;
+ if ptr_ok, the decl itself is permitted to have the POINTER attribute.
+ if shallow_alloc_only, returns only true if any of the fields is an
+ allocatable; called with true by gfc_omp_replace_alloc_by_to_mapping. */
static bool
-gfc_has_alloc_comps (tree type, tree decl)
+gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok,
+ bool shallow_alloc_only=false)
{
tree field, ftype;
if (POINTER_TYPE_P (type))
{
- if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
+ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
+ || (ptr_ok && GFC_DECL_GET_SCALAR_POINTER (decl)))
type = TREE_TYPE (type);
else if (GFC_DECL_GET_SCALAR_POINTER (decl))
return false;
}
- if (GFC_DESCRIPTOR_TYPE_P (type)
+ if (!ptr_ok
+ && GFC_DESCRIPTOR_TYPE_P (type)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return false;
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
return true;
- if (gfc_has_alloc_comps (ftype, field))
+ if (!shallow_alloc_only
+ && gfc_has_alloc_comps (ftype, field, false))
return true;
}
return false;
}
+/* gfc_omp_replace_alloc_by_to_mapping is used with gfc_omp_deep_mapping... to
+ handle the following:
+
+ For map(alloc: dt), the array descriptors of allocatable components should
+ be mapped as 'to'; this could be done by (A) adding 'map(to: dt%alloc_comp)'
+ for each component (and avoiding to increment the reference count).
+ Or (B) by just mapping all of 'dt' as 'to'.
+
+ If 'dt' contains several allocatable components and not much other data,
+ (A) is more efficient. If 'dt' contains a large const-size array, (A) will
+ copy it to the device instead of only 'alloc'ating it.
+
+ IMPLEMENTATION CHOICE: We do (A). It avoids the ref-count issue and it is
+ expected that, for real-world code, derived types with allocatable
+ components only have few other components and either no const-size arrays.
+ This copying is done irrespectively whether the allocatables are allocated.
+
+ If users wanted to save memory, they have to use 'map(alloc:dt%comp)' as
+ also with 'map(alloc:dt)' all components get copied.
+
+ For the copy to the device, only allocatable arrays are relevant as their
+ the bounds are required; the pointer is set separately (GOMP_MAP_ATTACH)
+ and the only setting required for scalars. However, when later copying out
+ of the device, an unallocated allocatable must remain unallocated/NULL on
+ the host; to achieve this we also must have it set to NULL on the device
+ to avoid issues with uninitialized memory being copied back for the pointer
+ address. If we could set the pointer to NULL, gfc_has_alloc_comps's
+ shallow_alloc_only could be restricted to return true only for arrays.
+
+ We only need to return true if there are allocatable-array components. */
+
+static bool
+gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok)
+{
+ return gfc_has_alloc_comps (type, decl, ptr_ok, true);
+}
+
+
/* Return true if TYPE is polymorphic but not with pointer attribute. */
static bool
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
return true;
- if (gfc_has_alloc_comps (type, decl))
+ if (gfc_has_alloc_comps (type, decl, false))
return true;
return false;
{
tree ftype = TREE_TYPE (field);
tree declf, destf = NULL_TREE;
- bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
+ bool has_alloc_comps = gfc_has_alloc_comps (ftype, field, false);
if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
|| GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gcc_assert (outer);
gfc_start_block (&block);
else
gfc_add_modify (&cond_block, unshare_expr (decl),
fold_convert (TREE_TYPE (decl), ptr));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (outer, decl,
OMP_CLAUSE_DECL (clause),
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gfc_start_block (&block);
gfc_add_modify (&block, dest, src);
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gfc_start_block (&block);
/* First dealloc any allocatable components in DEST. */
gfc_start_block (&block);
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
return gfc_walk_alloc_comps (decl, NULL_TREE,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
tem = gfc_call_free (decl);
tem = gfc_omp_unshare_expr (tem);
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
stmtblock_t block;
tree then_b;
return;
tree decl = OMP_CLAUSE_DECL (c);
+ location_t loc = OMP_CLAUSE_LOCATION (c);
/* Assumed-size arrays can't be mapped implicitly, they have to be
mapped explicitly using array sections. */
return;
}
- if (!openacc && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- warning_at (OMP_CLAUSE_LOCATION (c), OPT_Wopenmp,
- "Implicit mapping of polymorphic variable %qD is "
- "unspecified behavior", decl);
-
tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
tree present = gfc_omp_check_optional_argument (decl, true);
+ tree orig_decl = NULL_TREE;
if (POINTER_TYPE_P (TREE_TYPE (decl)))
{
if (!gfc_omp_privatize_by_reference (decl)
&& !GFC_DECL_CRAY_POINTEE (decl)
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
return;
- tree orig_decl = decl;
+ orig_decl = decl;
c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
{
- c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (c2) = decl;
+ OMP_CLAUSE_DECL (c2) = unshare_expr (decl);
OMP_CLAUSE_SIZE (c2) = size_int (0);
stmtblock_t block;
gfc_start_block (&block);
- tree ptr = decl;
- ptr = gfc_build_cond_assign_expr (&block, present, decl,
- null_pointer_node);
+ tree ptr = gfc_build_cond_assign_expr (&block, present,
+ unshare_expr (decl),
+ null_pointer_node);
gimplify_and_add (gfc_finish_block (&block), pre_p);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
{
c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
+ OMP_CLAUSE_DECL (c3) = decl;
OMP_CLAUSE_SIZE (c3) = size_int (0);
decl = build_fold_indirect_ref (decl);
- OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_DECL (c) = unshare_expr (decl);
}
}
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
- c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
if (present)
{
: GOMP_MAP_POINTER);
if (present)
{
- ptr = gfc_conv_descriptor_data_get (decl);
+ ptr = gfc_conv_descriptor_data_get (unshare_expr (decl));
ptr = gfc_build_addr_expr (NULL, ptr);
ptr = gfc_build_cond_assign_expr (&block, present,
ptr, null_pointer_node);
tree size = create_tmp_var (gfc_array_index_type);
tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
elemsz = fold_convert (gfc_array_index_type, elemsz);
+
+ if (orig_decl == NULL_TREE)
+ orig_decl = decl;
+ if (!openacc
+ && gfc_has_alloc_comps (type, orig_decl, true))
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ gfc_allocate_lang_decl (size);
+ GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
+ }
enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
if (akind == GFC_ARRAY_ALLOCATABLE
|| akind == GFC_ARRAY_POINTER
else_b = gfc_finish_block (&cond_block);
tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
tem = fold_convert (pvoid_type_node, tem);
- cond = fold_build2_loc (input_location, NE_EXPR,
+ cond = fold_build2_loc (loc, NE_EXPR,
boolean_type_node, tem, null_pointer_node);
if (present)
{
- cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ cond = fold_build2_loc (loc, TRUTH_ANDIF_EXPR,
boolean_type_node, present, cond);
}
- gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+ gfc_add_expr_to_block (&block, build3_loc (loc, COND_EXPR,
void_type_node, cond,
then_b, else_b));
}
tree stmt = gfc_finish_block (&block);
gimplify_and_add (stmt, pre_p);
}
+ else
+ {
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c)
+ = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type)))
+ type = TREE_TYPE (type);
+ if (!openacc
+ && orig_decl != NULL_TREE
+ && gfc_has_alloc_comps (type, orig_decl, true))
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ tree size = create_tmp_var (TREE_TYPE (OMP_CLAUSE_SIZE (c)));
+ gfc_allocate_lang_decl (size);
+ GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
+ gimplify_assign (size, OMP_CLAUSE_SIZE (c), pre_p);
+ OMP_CLAUSE_SIZE (c) = size;
+ }
+ }
tree last = c;
- if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
- OMP_CLAUSE_SIZE (c)
- = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
- : TYPE_SIZE_UNIT (TREE_TYPE (decl));
if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
OMP_CLAUSE_SIZE (c) = size_int (0);
}
+/* map(<flag>: data [len: <size>])
+ map(attach: &data [bias: <bias>])
+ offset += 2; offset_data += 2 */
+static void
+gfc_omp_deep_mapping_map (tree data, tree size, unsigned HOST_WIDE_INT tkind,
+ location_t loc, tree data_array, tree sizes_array,
+ tree kinds_array, tree offset_data, tree offset,
+ gimple_seq *seq, const gimple *ctx)
+{
+ tree one = build_int_cst (size_type_node, 1);
+
+ STRIP_NOPS (data);
+ if (!POINTER_TYPE_P (TREE_TYPE (data)))
+ {
+ gcc_assert (TREE_CODE (data) == INDIRECT_REF);
+ data = TREE_OPERAND (data, 0);
+ }
+
+ /* data_array[offset_data] = data; */
+ tree tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
+ unshare_expr (data_array), offset_data,
+ NULL_TREE, NULL_TREE);
+ gimplify_assign (tmp, data, seq);
+
+ /* offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
+ gimplify_assign (offset_data, tmp, seq);
+
+ /* data_array[offset_data] = &data; */
+ tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
+ unshare_expr (data_array),
+ offset_data, NULL_TREE, NULL_TREE);
+ gimplify_assign (tmp, build_fold_addr_expr (data), seq);
+
+ /* offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
+ gimplify_assign (offset_data, tmp, seq);
+
+ /* sizes_array[offset] = size */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (size_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
+ sizes_array, tmp);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, size, seq);
+
+ /* FIXME: tkind |= talign << talign_shift; */
+ /* kinds_array[offset] = tkind. */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
+ kinds_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
+
+ /* offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
+ gimplify_assign (offset, tmp, seq);
+
+ /* sizes_array[offset] = bias (= 0). */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (size_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
+ sizes_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_zero_cst (size_type_node), seq);
+
+ gcc_assert (gimple_code (ctx) == GIMPLE_OMP_TARGET);
+ tkind = (gimple_omp_target_kind (ctx) == GF_OMP_TARGET_KIND_EXIT_DATA
+ ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH);
+
+ /* kinds_array[offset] = tkind. */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
+ kinds_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
+
+ /* offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
+ gimplify_assign (offset, tmp, seq);
+}
+
+static void gfc_omp_deep_mapping_item (bool, bool, bool, location_t, tree,
+ tree *, unsigned HOST_WIDE_INT, tree,
+ tree, tree, tree, tree, tree,
+ gimple_seq *, const gimple *, bool *);
+
+/* Map allocatable components. */
+static void
+gfc_omp_deep_mapping_comps (bool is_cnt, location_t loc, tree decl,
+ tree *token, unsigned HOST_WIDE_INT tkind,
+ tree data_array, tree sizes_array, tree kinds_array,
+ tree offset_data, tree offset, tree num,
+ gimple_seq *seq, const gimple *ctx,
+ bool *poly_warned)
+{
+ tree type = TREE_TYPE (decl);
+ if (TREE_CODE (type) != RECORD_TYPE)
+ return;
+ for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
+ {
+ type = TREE_TYPE (field);
+ if (gfc_is_polymorphic_nonptr (type)
+ || GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
+ || (GFC_DESCRIPTOR_TYPE_P (type)
+ && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE))
+ {
+ tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
+ gfc_omp_deep_mapping_item (is_cnt, true, true, loc, tmp, token,
+ tkind, data_array, sizes_array,
+ kinds_array, offset_data, offset, num,
+ seq, ctx, poly_warned);
+ }
+ else if (GFC_DECL_GET_SCALAR_POINTER (field)
+ || GFC_DESCRIPTOR_TYPE_P (type))
+ continue;
+ else if (gfc_has_alloc_comps (TREE_TYPE (field), field, false))
+ {
+ tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
+ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ gfc_omp_deep_mapping_item (is_cnt, false, false, loc, tmp,
+ token, tkind, data_array, sizes_array,
+ kinds_array, offset_data, offset, num,
+ seq, ctx, poly_warned);
+ else
+ gfc_omp_deep_mapping_comps (is_cnt, loc, tmp, token, tkind,
+ data_array, sizes_array, kinds_array,
+ offset_data, offset, num, seq, ctx,
+ poly_warned);
+ }
+ }
+}
+
+static void
+gfc_omp_gen_simple_loop (tree var, tree begin, tree end, enum tree_code cond,
+ tree step, location_t loc, gimple_seq *seq1,
+ gimple_seq *seq2)
+{
+ tree tmp;
+
+ /* var = begin. */
+ gimplify_assign (var, begin, seq1);
+
+ /* Loop: for (var = begin; var <cond> end; var += step). */
+ tree label_loop = create_artificial_label (loc);
+ tree label_cond = create_artificial_label (loc);
+
+ gimplify_and_add (fold_build1_loc (loc, GOTO_EXPR, void_type_node,
+ label_cond), seq1);
+ gimple_seq_add_stmt (seq1, gimple_build_label (label_loop));
+
+ /* Everything above is seq1; place loop body here. */
+
+ /* End of loop body -> put into seq2. */
+ tmp = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (var), var, step);
+ gimplify_assign (var, tmp, seq2);
+ gimple_seq_add_stmt (seq2, gimple_build_label (label_cond));
+ tmp = fold_build2_loc (loc, cond, boolean_type_node, var, end);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
+ build_empty_stmt (loc));
+ gimplify_and_add (tmp, seq2);
+}
+
+/* Return size variable with the size of an array. */
+static tree
+gfc_omp_get_array_size (location_t loc, tree desc, gimple_seq *seq)
+{
+ tree tmp;
+ gimple_seq seq1 = NULL, seq2 = NULL;
+ tree size = build_decl (loc, VAR_DECL, create_tmp_var_name ("size"),
+ size_type_node);
+ tree extent = build_decl (loc, VAR_DECL, create_tmp_var_name ("extent"),
+ gfc_array_index_type);
+ tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
+ signed_char_type_node);
+
+ tree begin = build_zero_cst (signed_char_type_node);
+ tree end;
+ if (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE)
+ end = gfc_conv_descriptor_rank (desc);
+ else
+ end = build_int_cst (signed_char_type_node,
+ GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+ tree step = build_int_cst (signed_char_type_node, 1);
+
+ /* size = 0
+ for (idx = 0; idx < rank; idx++)
+ extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
+ if (extent < 0) extent = 0
+ size *= extent. */
+ gimplify_assign (size, build_int_cst (size_type_node, 1), seq);
+
+ gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, &seq1, &seq2);
+ gimple_seq_add_seq (seq, seq1);
+
+ tmp = fold_build2_loc (loc, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ gfc_conv_descriptor_lbound_get (desc, idx));
+ tmp = fold_build2_loc (loc, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gimplify_assign (extent, tmp, seq);
+ tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node,
+ extent, gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, tmp,
+ fold_build2_loc (loc, MODIFY_EXPR,
+ gfc_array_index_type,
+ extent, gfc_index_zero_node),
+ build_empty_stmt (loc));
+ gimplify_and_add (tmp, seq);
+ /* size *= extent. */
+ gimplify_assign (size, fold_build2_loc (loc, MULT_EXPR, size_type_node, size,
+ fold_convert (size_type_node,
+ extent)), seq);
+ gimple_seq_add_seq (seq, seq2);
+ return size;
+}
+
+/* Generate loop to access every array element; takes addr of first element
+ (decl's data comp); returns loop code in seq1 + seq2
+ and the pointer to the element as return value. */
+static tree
+gfc_omp_elmental_loop (location_t loc, tree decl, tree size, tree elem_len,
+ gimple_seq *seq1, gimple_seq *seq2)
+{
+ tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
+ size_type_node);
+ tree begin = build_zero_cst (size_type_node);
+ tree end = size;
+ tree step = build_int_cst (size_type_node, 1);
+ tree ptr;
+
+ gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, seq1, seq2);
+
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ {
+ type = TREE_TYPE (type);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
+ }
+ else
+ {
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ decl = build_fold_addr_expr_loc (loc, decl);
+ }
+ decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
+ tree tmp = build2_loc (loc, MULT_EXPR, size_type_node, idx,
+ fold_convert (size_type_node, elem_len));
+ ptr = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, tmp);
+ gimple_seq seq3 = NULL;
+ ptr = force_gimple_operand (ptr, &seq3, true, NULL_TREE);
+ gimple_seq_add_seq (seq1, seq3);
+
+ return ptr;
+}
+
+
+/* If do_copy, copy data pointer and vptr (if applicable) as well.
+ Otherwise, only handle allocatable components.
+ do_copy == false can happen only with nonpolymorphic arguments
+ to a copy clause.
+ if (is_cnt) token ... offset is ignored and num is used, otherwise
+ num is NULL_TREE and unused. */
+
+static void
+gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check,
+ location_t loc, tree decl, tree *token,
+ unsigned HOST_WIDE_INT tkind, tree data_array,
+ tree sizes_array, tree kinds_array, tree offset_data,
+ tree offset, tree num, gimple_seq *seq,
+ const gimple *ctx, bool *poly_warned)
+{
+ tree tmp;
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ tree end_label = NULL_TREE;
+ tree size = NULL_TREE, elem_len = NULL_TREE;
+
+ bool poly = gfc_is_polymorphic_nonptr (type);
+ if (poly && is_cnt && !*poly_warned)
+ {
+ if (gfc_is_unlimited_polymorphic_nonptr (type))
+ error_at (loc,
+ "Mapping of unlimited polymorphic list item %qD is "
+ "unspecified behavior and unsupported", decl);
+
+ else
+ warning_at (loc, OPT_Wopenmp,
+ "Mapping of polymorphic list item %qD is "
+ "unspecified behavior", decl);
+ *poly_warned = true;
+ }
+ if (do_alloc_check)
+ {
+ tree then_label = create_artificial_label (loc);
+ end_label = create_artificial_label (loc);
+ tmp = decl;
+ if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE
+ || (POINTER_TYPE_P (TREE_TYPE (tmp))
+ && (POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
+ || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))))))
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ if (poly)
+ tmp = gfc_class_data_get (tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+
+ gimple_seq_add_stmt (seq,
+ gimple_build_cond (NE_EXPR, tmp, null_pointer_node,
+ then_label, end_label));
+ gimple_seq_add_stmt (seq, gimple_build_label (then_label));
+ }
+ tree class_decl = decl;
+ if (poly)
+ {
+ decl = gfc_class_data_get (decl);
+ type = TREE_TYPE (decl);
+ }
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ {
+ decl = build_fold_indirect_ref (decl);
+ type = TREE_TYPE (decl);
+ }
+
+ if (is_cnt && do_copy)
+ {
+ tree tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node,
+ num, build_int_cst (size_type_node, 1));
+ gimplify_assign (num, tmp, seq);
+ }
+ else if (do_copy)
+ {
+ /* copy data pointer */
+ tree bytesize;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ /* TODO: Optimization: Shouldn't this be an expr. const, except for
+ deferred-length strings. (Cf. also below). */
+ elem_len = (poly ? gfc_class_vtab_size_get (class_decl)
+ : gfc_conv_descriptor_elem_len (decl));
+ tmp = (POINTER_TYPE_P (TREE_TYPE (decl))
+ ? build_fold_indirect_ref (decl) : decl);
+ size = gfc_omp_get_array_size (loc, tmp, seq);
+ bytesize = fold_build2_loc (loc, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, size),
+ fold_convert (size_type_node, elem_len));
+ tmp = gfc_conv_descriptor_data_get (decl);
+ }
+ else if (poly)
+ {
+ tmp = decl;
+ bytesize = fold_convert (size_type_node,
+ gfc_class_vtab_size_get (class_decl));
+ }
+ else
+ {
+ tmp = decl;
+ bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ }
+ unsigned HOST_WIDE_INT tkind2 = tkind;
+ if (!is_cnt
+ && (tkind == GOMP_MAP_ALLOC
+ || (tkind == GOMP_MAP_FROM
+ && (gimple_omp_target_kind (ctx)
+ != GF_OMP_TARGET_KIND_EXIT_DATA)))
+ && gfc_omp_replace_alloc_by_to_mapping (TREE_TYPE (decl), decl, true))
+ tkind2 = tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO : GOMP_MAP_TOFROM;
+
+ gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array,
+ sizes_array, kinds_array, offset_data,
+ offset, seq, ctx);
+ }
+
+ tmp = decl;
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ if (poly || gfc_has_alloc_comps (type, tmp, true))
+ {
+ gimple_seq seq2 = NULL;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ if (elem_len == NULL_TREE)
+ {
+ elem_len = gfc_conv_descriptor_elem_len (decl);
+ size = fold_convert (size_type_node,
+ gfc_omp_get_array_size (loc, decl, seq));
+ }
+ decl = gfc_conv_descriptor_data_get (decl);
+ decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
+ decl = build_fold_indirect_ref_loc (loc, decl);
+ }
+ else if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ {
+ type = TREE_TYPE (tmp);
+ /* FIXME: PR95868 - for var%str of deferred length, elem_len == 0;
+ len is stored as var%_str_length, but not in GFC_DECL_STRING_LEN
+ nor in TYPE_SIZE_UNIT as expression. */
+ elem_len = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ size = fold_convert (size_type_node, GFC_TYPE_ARRAY_SIZE (type));
+ decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
+ decl = build_fold_indirect_ref_loc (loc, decl);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref (decl);
+
+ gfc_omp_deep_mapping_comps (is_cnt, loc, decl, token, tkind,
+ data_array, sizes_array, kinds_array,
+ offset_data, offset, num, seq, ctx,
+ poly_warned);
+ gimple_seq_add_seq (seq, seq2);
+ }
+ if (end_label)
+ gimple_seq_add_stmt (seq, gimple_build_label (end_label));
+}
+
+
+/* Which map types to check/handle for deep mapping. */
+static bool
+gfc_omp_deep_map_kind_p (tree clause)
+{
+ switch (OMP_CLAUSE_CODE (clause))
+ {
+ case OMP_CLAUSE_MAP:
+ break;
+ case OMP_CLAUSE_FIRSTPRIVATE:
+ case OMP_CLAUSE_TO:
+ case OMP_CLAUSE_FROM:
+ return true;
+ default:
+ gcc_unreachable ();
+ }
+
+ switch (OMP_CLAUSE_MAP_KIND (clause))
+ {
+ case GOMP_MAP_TO:
+ case GOMP_MAP_FROM:
+ case GOMP_MAP_TOFROM:
+ case GOMP_MAP_ALWAYS_TO:
+ case GOMP_MAP_ALWAYS_FROM:
+ case GOMP_MAP_ALWAYS_TOFROM:
+ case GOMP_MAP_ALWAYS_PRESENT_FROM:
+ case GOMP_MAP_ALWAYS_PRESENT_TO:
+ case GOMP_MAP_ALWAYS_PRESENT_TOFROM:
+ case GOMP_MAP_FIRSTPRIVATE:
+ case GOMP_MAP_ALLOC:
+ return true;
+ case GOMP_MAP_POINTER:
+ case GOMP_MAP_TO_PSET:
+ case GOMP_MAP_FORCE_PRESENT:
+ case GOMP_MAP_DELETE:
+ case GOMP_MAP_FORCE_DEVICEPTR:
+ case GOMP_MAP_DEVICE_RESIDENT:
+ case GOMP_MAP_LINK:
+ case GOMP_MAP_IF_PRESENT:
+ case GOMP_MAP_PRESENT_ALLOC:
+ case GOMP_MAP_PRESENT_FROM:
+ case GOMP_MAP_PRESENT_TO:
+ case GOMP_MAP_PRESENT_TOFROM:
+ case GOMP_MAP_FIRSTPRIVATE_INT:
+ case GOMP_MAP_USE_DEVICE_PTR:
+ case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
+ case GOMP_MAP_FORCE_ALLOC:
+ case GOMP_MAP_FORCE_TO:
+ case GOMP_MAP_FORCE_FROM:
+ case GOMP_MAP_FORCE_TOFROM:
+ case GOMP_MAP_USE_DEVICE_PTR_IF_PRESENT:
+ case GOMP_MAP_STRUCT:
+ case GOMP_MAP_STRUCT_UNORD:
+ case GOMP_MAP_ALWAYS_POINTER:
+ case GOMP_MAP_POINTER_TO_ZERO_LENGTH_ARRAY_SECTION:
+ case GOMP_MAP_DELETE_ZERO_LEN_ARRAY_SECTION:
+ case GOMP_MAP_RELEASE:
+ case GOMP_MAP_ATTACH:
+ case GOMP_MAP_DETACH:
+ case GOMP_MAP_FORCE_DETACH:
+ case GOMP_MAP_ATTACH_ZERO_LENGTH_ARRAY_SECTION:
+ case GOMP_MAP_FIRSTPRIVATE_POINTER:
+ case GOMP_MAP_FIRSTPRIVATE_REFERENCE:
+ case GOMP_MAP_ATTACH_DETACH:
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ return false;
+}
+
+/* Three OpenMP deep-mapping lang hooks: gfc_omp_deep_mapping{_p,_cnt,}. */
+
+/* Common check for gfc_omp_deep_mapping_p and gfc_omp_deep_mapping_do. */
+
+static tree
+gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause)
+{
+ if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause))
+ return NULL_TREE;
+ tree decl = OMP_CLAUSE_DECL (clause);
+ if (OMP_CLAUSE_SIZE (clause) != NULL_TREE
+ && DECL_P (OMP_CLAUSE_SIZE (clause))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)))
+ /* Saved decl. */
+ decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause));
+ else if (TREE_CODE (decl) == MEM_REF || TREE_CODE (decl) == INDIRECT_REF)
+ /* The following can happen for, e.g., class(t) :: var(..) */
+ decl = TREE_OPERAND (decl, 0);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ /* The following can happen for, e.g., class(t) :: var(..) */
+ decl = TREE_OPERAND (decl, 0);
+ if (DECL_P (decl)
+ && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ /* Handle map(to: var.desc) map([to/from/tofrom:] var.desc.data)
+ to get proper map kind by skipping to the next item. */
+ tree tmp = OMP_CLAUSE_CHAIN (clause);
+ if (tmp != NULL_TREE
+ && OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_CODE (clause)
+ && OMP_CLAUSE_SIZE (tmp) != NULL_TREE
+ && DECL_P (OMP_CLAUSE_SIZE (tmp))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (tmp))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl)
+ return NULL_TREE;
+ if (DECL_P (decl)
+ && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ tmp = decl;
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ if (!gfc_is_polymorphic_nonptr (type)
+ && !gfc_has_alloc_comps (type, tmp, true))
+ return NULL_TREE;
+ return decl;
+}
+
+/* Return true if there is deep mapping, even if the number of mapping is known
+ at compile time. */
+bool
+gfc_omp_deep_mapping_p (const gimple *ctx, tree clause)
+{
+ tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
+ if (decl == NULL_TREE)
+ return false;
+ return true;
+}
+
+/* Handle gfc_omp_deep_mapping{,_cnt} */
+static tree
+gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause,
+ unsigned HOST_WIDE_INT tkind, tree data, tree sizes,
+ tree kinds, tree offset_data, tree offset,
+ gimple_seq *seq)
+{
+ tree num = NULL_TREE;
+ location_t loc = OMP_CLAUSE_LOCATION (clause);
+ tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
+ bool poly_warned = false;
+ if (decl == NULL_TREE)
+ return NULL_TREE;
+ /* Handle: map(alloc:dt%cmp [len: ptr_size]) map(tofrom: D.0123...),
+ where GFC_DECL_SAVED_DESCRIPTOR(D.0123) is the same (here: dt%cmp). */
+ if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
+ && (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC
+ || OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_PRESENT_ALLOC))
+ {
+ tree c = clause;
+ while ((c = OMP_CLAUSE_CHAIN (c)) != NULL_TREE)
+ {
+ if (!gfc_omp_deep_map_kind_p (c))
+ continue;
+ tree d = gfc_omp_deep_mapping_int_p (ctx, c);
+ if (d != NULL_TREE && operand_equal_p (decl, d, 0))
+ return NULL_TREE;
+ }
+ }
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ bool poly = gfc_is_polymorphic_nonptr (type);
+
+ if (is_cnt)
+ {
+ num = build_decl (loc, VAR_DECL,
+ create_tmp_var_name ("n_deepmap"), size_type_node);
+ tree tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num,
+ build_int_cst (size_type_node, 0));
+ gimple_add_tmp_var (num);
+ gimplify_and_add (tmp, seq);
+ }
+ else
+ gcc_assert (short_unsigned_type_node == TREE_TYPE (TREE_TYPE (kinds)));
+
+ bool do_copy = poly;
+ bool do_alloc_check = false;
+ tree token = NULL_TREE;
+ tree tmp = decl;
+ if (poly)
+ {
+ tmp = TYPE_FIELDS (type);
+ type = TREE_TYPE (tmp);
+ }
+ else
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ /* If the clause argument is nonallocatable, skip is-allocate check. */
+ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
+ || GFC_DECL_GET_SCALAR_POINTER (tmp)
+ || (GFC_DESCRIPTOR_TYPE_P (type)
+ && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)))
+ do_alloc_check = true;
+
+ if (!is_cnt
+ && OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
+ && (tkind == GOMP_MAP_ALLOC
+ || (tkind == GOMP_MAP_FROM
+ && (gimple_omp_target_kind (ctx)
+ != GF_OMP_TARGET_KIND_EXIT_DATA)))
+ && (poly || gfc_omp_replace_alloc_by_to_mapping (type, tmp, true)))
+ OMP_CLAUSE_SET_MAP_KIND (clause, tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO
+ : GOMP_MAP_TOFROM);
+
+ /* TODO: For map(a(:)), we know it is present & allocated. */
+
+ tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true)
+ : NULL_TREE);
+ if (POINTER_TYPE_P (TREE_TYPE (decl))
+ && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
+ decl = build_fold_indirect_ref (decl);
+ if (present)
+ {
+ tree then_label = create_artificial_label (loc);
+ tree end_label = create_artificial_label (loc);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (present, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ gimple_seq_add_stmt (seq,
+ gimple_build_cond_from_tree (present,
+ then_label, end_label));
+ gimple_seq_add_stmt (seq, gimple_build_label (then_label));
+ gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
+ &token, tkind, data, sizes, kinds,
+ offset_data, offset, num, seq, ctx,
+ &poly_warned);
+ gimple_seq_add_stmt (seq, gimple_build_label (end_label));
+ }
+ else
+ gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
+ &token, tkind, data, sizes, kinds, offset_data,
+ offset, num, seq, ctx, &poly_warned);
+ /* Multiply by 2 as there are two mappings: data + pointer assign. */
+ if (is_cnt)
+ gimplify_assign (num,
+ fold_build2_loc (loc, MULT_EXPR,
+ size_type_node, num,
+ build_int_cst (size_type_node, 2)), seq);
+ return num;
+}
+
+/* Return tree with a variable which contains the count of deep-mappyings
+ (value depends, e.g., on allocation status) */
+tree
+gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq)
+{
+ return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE, seq);
+}
+
+/* Does the actual deep mapping. */
+void
+gfc_omp_deep_mapping (const gimple *ctx, tree clause,
+ unsigned HOST_WIDE_INT tkind, tree data,
+ tree sizes, tree kinds, tree offset_data, tree offset,
+ gimple_seq *seq)
+{
+ (void) gfc_omp_deep_mapping_do (false, ctx, clause, tkind, data, sizes, kinds,
+ offset_data, offset, seq);
+}
+
/* Return true if DECL is a scalar variable (for the purpose of
implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
is true, allocatables and pointers are permitted. */
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);
+ if (n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
}
gcc_assert (se.post.head == NULL_TREE);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
if (!n->sym->attr.referenced)
continue;
+ location_t map_loc = gfc_get_location (&n->where);
bool always_modifier = false;
- tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
tree node2 = NULL_TREE;
tree node3 = NULL_TREE;
tree node4 = NULL_TREE;
&& n->u.map.op != OMP_MAP_RELEASE)
{
gcc_assert (n->sym->ts.u.cl->backend_decl);
- node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
OMP_CLAUSE_SIZE (node5)
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node) = ptr;
OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
- node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
OMP_CLAUSE_SIZE (node2) = size_int (0);
size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
else
size = size_int (0);
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
OMP_CLAUSE_DECL (node4) = decl;
OMP_CLAUSE_SIZE (node4) = size;
size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
else
size = size_int (0);
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
OMP_CLAUSE_DECL (node3) = decl;
OMP_CLAUSE_SIZE (node3) = size;
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node) = ptr;
- node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_DECL (node2) = decl;
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (n->u.map.op == OMP_MAP_DELETE)
&& n->u.map.op != OMP_MAP_DELETE
&& n->u.map.op != OMP_MAP_RELEASE)
{
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
if (present)
{
ptr = gfc_conv_descriptor_data_get (decl);
{
/* A single indirectref is handled by the middle end. */
gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
- decl = TREE_OPERAND (decl, 0);
- decl = gfc_build_cond_assign_expr (block, present, decl,
+ tree tmp = TREE_OPERAND (decl, 0);
+ tmp = gfc_build_cond_assign_expr (block, present, tmp,
null_pointer_node);
- OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl);
+ OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp);
}
else
OMP_CLAUSE_DECL (node) = decl;
size = gfc_evaluate_now (size, block);
OMP_CLAUSE_SIZE (node) = size;
}
+ if ((TREE_CODE (decl) != PARM_DECL
+ || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node)))
+ && n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ if (tmp == NULL_TREE)
+ tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ decl = TREE_OPERAND (decl, 0);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ decl = TREE_OPERAND (decl, 0);
+ if (DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ GFC_DECL_SAVED_DESCRIPTOR (var)
+ = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ else
+ GFC_DECL_SAVED_DESCRIPTOR (var) = decl;
+ }
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
goto finalize_map_clause;
}
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
kind = GOMP_MAP_RELEASE;
else
kind = GOMP_MAP_TO;
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, kind);
OMP_CLAUSE_DECL (node3) = se.string_length;
OMP_CLAUSE_SIZE (node3)
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
}
+ if (!openacc
+ && n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ if (tmp == NULL_TREE)
+ tmp = (DECL_P (se.expr)
+ ? DECL_SIZE_UNIT (se.expr)
+ : TYPE_SIZE_UNIT (TREE_TYPE (se.expr)));
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (se.expr) == INDIRECT_REF)
+ se.expr = TREE_OPERAND (se.expr, 0);
+ if (DECL_LANG_SPECIFIC (se.expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (se.expr))
+ GFC_DECL_SAVED_DESCRIPTOR (var)
+ = GFC_DECL_SAVED_DESCRIPTOR (se.expr);
+ else
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
}
}
else if (n->expr
&& (lastref->u.c.component->ts.type == BT_DERIVED
|| lastref->u.c.component->ts.type == BT_CLASS))
{
- if (pointer || (openacc && allocatable))
+ if (pointer || allocatable)
{
/* If it's a bare attach/detach clause, we just want
to perform a single attach/detach operation, of the
OMP_CLAUSE_DECL (node) = data;
OMP_CLAUSE_SIZE (node) = size;
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2,
GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
OMP_CLAUSE_SIZE (node)
= TYPE_SIZE_UNIT (TREE_TYPE (inner));
}
+ if (!openacc
+ && n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (inner) == INDIRECT_REF)
+ inner = TREE_OPERAND (inner, 0);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
+ }
}
else if (lastref->type == REF_ARRAY
&& lastref->u.ar.type == AR_FULL)
elemsz = TYPE_SIZE_UNIT (elemsz);
elemsz = fold_build2 (MULT_EXPR, size_type_node,
len, elemsz);
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
OMP_CLAUSE_DECL (node4) = se.string_length;
OMP_CLAUSE_SIZE (node4)
OMP_CLAUSE_SIZE (node)
= fold_build2 (MULT_EXPR, gfc_array_index_type,
OMP_CLAUSE_SIZE (node), elemsz);
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
if (map_kind == GOMP_MAP_RELEASE
|| map_kind == GOMP_MAP_DELETE)
{
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (!openacc)
{
+ if (n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use
+ in gfc_omp_deep_mapping{,_p,_cnt}; force
+ evaluate to ensure that it is
+ not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp),
+ NULL);
+ gfc_add_modify_loc (map_loc, block,
+ var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
+ }
+
gfc_omp_namelist *n2
= clauses->lists[OMP_LIST_MAP];
if (drop_mapping)
continue;
}
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3,
GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node3)
default:
gcc_unreachable ();
}
- tree node = build_omp_clause (input_location, clause_code);
+ tree node = build_omp_clause (gfc_get_location (&n->where),
+ clause_code);
if (n->expr == NULL
|| (n->expr->ref->type == REF_ARRAY
&& n->expr->ref->u.ar.type == AR_FULL
tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree);
tree gfc_omp_clause_dtor (tree, tree);
void gfc_omp_finish_clause (tree, gimple_seq *, bool);
+bool gfc_omp_deep_mapping_p (const gimple *, tree);
+tree gfc_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *);
+void gfc_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT, tree,
+ tree, tree, tree, tree, gimple_seq *);
bool gfc_omp_allocatable_p (tree);
bool gfc_omp_scalar_p (tree, bool);
bool gfc_omp_scalar_target_p (tree);
end type
type(sct) var
-!$omp target enter data map(to:var) ! { dg-error "allocatable components is not permitted in map clause" }
+!$omp target enter data map(to:var)
end
--- /dev/null
+type t
+ integer :: t
+end type t
+class(t), target, allocatable :: c, ca(:)
+class(t), pointer :: p, pa(:)
+integer :: x
+allocate( t :: c, ca(5))
+p => c
+pa => ca
+
+! 11111111112222222222333333333344
+!2345678901234567890123456789012345678901
+!$omp target enter data map(c, ca, p, pa)
+! { dg-warning "29:Mapping of polymorphic list item 'c' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
+! { dg-warning "32:Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "36:Mapping of polymorphic list item 'p' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+! { dg-warning "39:Mapping of polymorphic list item 'pa' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
+
+! 11111111112222222222333333333344
+!2345678901234567890123456789012345678901
+
+! 11111111112222222222333333333344
+!2345678901234567890123456789012345678901
+!$omp target update from(c,ca), to(p,pa)
+! { dg-warning "26:Mapping of polymorphic list item 'c' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
+! { dg-warning "28:Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "36:Mapping of polymorphic list item 'p' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+! { dg-warning "38:Mapping of polymorphic list item 'pa' is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
+
+end
p => c
pa => ca
-!$omp target ! { dg-warning "Implicit mapping of polymorphic variable 'ca' is unspecified behavior \\\[-Wopenmp\\\]" }
+!$omp target ! { dg-warning "Mapping of polymorphic list item 'ca' is unspecified behavior \\\[-Wopenmp\\\]" }
ll = allocated(ca)
!$omp end target
--- /dev/null
+subroutine sub(var, var2)
+type t
+ integer :: x
+end type t
+
+type t2
+ integer :: x
+ integer, allocatable :: y
+end type
+
+class(t) var, var2
+type(t2) :: var3, var4
+!$omp target firstprivate(var) & ! { dg-error "Polymorphic list item 'var' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" }
+!$omp& private(var2) ! { dg-error "Polymorphic list item 'var2' at .1. in PRIVATE clause has unspecified behavior and unsupported" }
+ var%x = 5
+ var2%x = 5
+!$omp end target
+!$omp target firstprivate(var3) & ! { dg-error "Sorry, list item 'var3' at .1. with allocatable components is not yet supported in FIRSTPRIVATE clause" }
+!$omp& private(var4) ! { dg-error "Sorry, list item 'var4' at .1. with allocatable components is not yet supported in PRIVATE clause" }
+ var3%x = 5
+ var4%x = 5
+!$omp end target
+end
--- /dev/null
+subroutine one
+implicit none
+type t
+ class(*), allocatable :: ul
+end type
+
+type(t) :: var
+!$omp target enter data map(to:var) ! { dg-error "Mapping of unlimited polymorphic list item 'var.ul' is unspecified behavior and unsupported" }
+end
--- /dev/null
+subroutine one
+implicit none
+type t
+ class(*), allocatable :: ul
+end type
+
+class(*), allocatable :: ul_var
+!$omp target enter data map(to: ul_var) ! { dg-error "Mapping of unlimited polymorphic list item 'ul_var' is unspecified behavior and unsupported" }
+end
! 11111111112222222222333333333344
!2345678901234567890123456789012345678901
-!$omp target enter data map(c, ca, p, pa)
-! { dg-warning "29:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
-! { dg-warning "32:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
-! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
-! { dg-warning "39:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
-
-! 11111111112222222222333333333344
-!2345678901234567890123456789012345678901
-!$omp target firstprivate(ca) ! { dg-warning "27:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
+!$omp target firstprivate(ca) ! { dg-error "27:Polymorphic list item 'ca' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" }
!$omp end target
-!$omp target parallel do firstprivate(ca) ! { dg-warning "39:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
+!$omp target parallel do firstprivate(ca) ! { dg-error "39:Polymorphic list item 'ca' at .1. in FIRSTPRIVATE clause has unspecified behavior and unsupported" }
do x = 0, 5
end do
-!$omp target parallel do private(ca) ! OK; should map declared type
+!$omp target parallel do private(ca) ! { dg-error "34:Polymorphic list item 'ca' at .1. in PRIVATE clause has unspecified behavior and unsupported" }
do x = 0, 5
end do
-!$omp target private(ca) ! OK; should map declared type
+!$omp target private(ca) ! { dg-error "22:Polymorphic list item 'ca' at .1. in PRIVATE clause has unspecified behavior and unsupported" }
block
end block
-! 11111111112222222222333333333344
-!2345678901234567890123456789012345678901
-!$omp target update from(c,ca), to(p,pa)
-! { dg-warning "26:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
-! { dg-warning "28:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
-! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
-! { dg-warning "38:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
-
! -------------------------
!$omp target parallel map(release: x) ! { dg-error "36:TARGET with map-type other than TO, FROM, TOFROM, or ALLOC on MAP clause" }
device memory mapped by an array section @tab P @tab
@item Mapping of Fortran pointer and allocatable variables, including pointer
and allocatable components of variables
- @tab P @tab Mapping of vars with allocatable components unsupported
+ @tab Y @tab
@item @code{defaultmap} extensions @tab Y @tab
@item @code{declare mapper} directive @tab N @tab
@item @code{omp_get_supported_active_levels} routine @tab Y @tab
--- /dev/null
+implicit none
+type t
+ integer, allocatable :: a, b(:)
+end type t
+type(t) :: x, y, z
+integer :: i
+
+!$omp target map(to: x)
+ if (allocated(x%a)) stop 1
+ if (allocated(x%b)) stop 2
+!$omp end target
+
+allocate(x%a, x%b(-4:6))
+x%b(:) = [(i, i=-4,6)]
+
+!$omp target map(to: x)
+ if (.not. allocated(x%a)) stop 3
+ if (.not. allocated(x%b)) stop 4
+ if (lbound(x%b,1) /= -4) stop 5
+ if (ubound(x%b,1) /= 6) stop 6
+ if (any (x%b /= [(i, i=-4,6)])) stop 7
+!$omp end target
+
+
+! The following only works with arrays due to
+! PR fortran/96668
+
+!$omp target enter data map(to: y, z)
+
+!$omp target map(to: y, z)
+ if (allocated(y%b)) stop 8
+ if (allocated(z%b)) stop 9
+!$omp end target
+
+allocate(y%b(5), z%b(3))
+y%b = 42
+z%b = 99
+
+! (implicitly) 'tofrom' mapped
+! Planned for OpenMP 6.0 (but common extension)
+! OpenMP <= 5.0 unclear
+!$omp target map(to: y)
+ if (.not.allocated(y%b)) stop 10
+ if (any (y%b /= 42)) stop 11
+!$omp end target
+
+! always map: OpenMP 5.1 (clarified)
+!$omp target map(always, tofrom: z)
+ if (.not.allocated(z%b)) stop 12
+ if (any (z%b /= 99)) stop 13
+!$omp end target
+
+end
--- /dev/null
+type t2
+ integer x, y, z
+end type t2
+type t
+ integer, allocatable :: A
+ integer, allocatable :: B(:)
+ type(t2), allocatable :: C
+ type(t2), allocatable :: D(:,:)
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+
+! --------------------------------------
+! Assign + allocate
+var%A = 45
+var%B = [1,2,3]
+var%C = t2(6,5,4)
+var%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var2%A = 145
+var2%B = [991,992,993]
+var2%C = t2(996,995,994)
+var2%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+
+!$omp target map(to: var) map(tofrom: var2)
+ call foo(var, var2)
+!$omp end target
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+if (any (var2%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 12
+if (any (var2%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 12
+if (any (var2%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 12
+
+! --------------------------------------
+! Assign + allocate
+var3%Q%A = 45
+var3%Q%B = [1,2,3]
+var3%Q%C = t2(6,5,4)
+var3%Q%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+var3%R(2)%A = 45
+var3%R(2)%B = [1,2,3]
+var3%R(2)%C = t2(6,5,4)
+var3%R(2)%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var4%Q%A = 145
+var4%Q%B = [991,992,993]
+var4%Q%C = t2(996,995,994)
+var4%Q%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+var4%R(3)%A = 145
+var4%R(3)%B = [991,992,993]
+var4%R(3)%C = t2(996,995,994)
+var4%R(3)%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+!$omp target map(to: var3%Q) map(tofrom: var4%Q)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+!$omp target map(to: var3%R(2)) map(tofrom: var4%R(3))
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+if (any (var4%Q%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 16
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+if (any (var4%R(3)%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 20
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+ if (any (x%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 4
+ if (any (x%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 4
+ if (any (x%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 4
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ if (any (y%D(:,:)%x /= reshape([199, 499, 1199, 1499], [2,2]))) stop 8
+ if (any (y%D(:,:)%y /= reshape([299, 599, 1299, 1599], [2,2]))) stop 8
+ if (any (y%D(:,:)%z /= reshape([399, 699, 1399, 1699], [2,2]))) stop 8
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C = x%C
+ y%D(:,:) = x%D(:,:)
+ end
+end
--- /dev/null
+type t2
+ integer x, y, z
+end type t2
+type t
+ integer, allocatable :: A
+ integer, allocatable :: B(:)
+ type(t2), allocatable :: C
+ type(t2), allocatable :: D(:,:)
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+
+! --------------------------------------
+! Assign + allocate
+var%A = 45
+var%B = [1,2,3]
+var%C = t2(6,5,4)
+var%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var2%A = 145
+var2%B = [991,992,993]
+var2%C = t2(996,995,994)
+var2%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+
+!$omp target map(to: var%A, var%B, var%C, var%D) &
+!$omp& map(tofrom: var2%A, var2%B, var2%C, var2%D)
+ call foo(var, var2)
+!$omp end target
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+if (any (var2%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 12
+if (any (var2%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 12
+if (any (var2%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 12
+
+! --------------------------------------
+! Assign + allocate
+var3%Q%A = 45
+var3%Q%B = [1,2,3]
+var3%Q%C = t2(6,5,4)
+var3%Q%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+var3%R(2)%A = 45
+var3%R(2)%B = [1,2,3]
+var3%R(2)%C = t2(6,5,4)
+var3%R(2)%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var4%Q%A = 145
+var4%Q%B = [991,992,993]
+var4%Q%C = t2(996,995,994)
+var4%Q%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+var4%R(3)%A = 145
+var4%R(3)%B = [991,992,993]
+var4%R(3)%C = t2(996,995,994)
+var4%R(3)%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+!$omp target map(to: var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D) &
+!$omp& map(tofrom: var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+if (any (var4%Q%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 16
+
+!$omp target map(to: var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D) &
+!$omp& map(tofrom: var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+if (any (var4%R(3)%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 20
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+ if (any (x%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 4
+ if (any (x%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 4
+ if (any (x%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 4
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ if (any (y%D(:,:)%x /= reshape([199, 499, 1199, 1499], [2,2]))) stop 8
+ if (any (y%D(:,:)%y /= reshape([299, 599, 1299, 1599], [2,2]))) stop 8
+ if (any (y%D(:,:)%z /= reshape([399, 699, 1399, 1699], [2,2]))) stop 8
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C = x%C
+ y%D(:,:) = x%D(:,:)
+ end
+end
--- /dev/null
+implicit none
+type t
+ integer, allocatable :: a, b(:)
+end type t
+type(t) :: x, y, z
+integer :: i
+
+!$omp target
+ if (allocated(x%a)) stop 1
+ if (allocated(x%b)) stop 2
+!$omp end target
+
+allocate(x%a, x%b(-4:6))
+x%b(:) = [(i, i=-4,6)]
+
+!$omp target
+ if (.not. allocated(x%a)) stop 3
+ if (.not. allocated(x%b)) stop 4
+ if (lbound(x%b,1) /= -4) stop 5
+ if (ubound(x%b,1) /= 6) stop 6
+ if (any (x%b /= [(i, i=-4,6)])) stop 7
+!$omp end target
+
+
+! The following only works with arrays due to
+! PR fortran/96668
+
+!$omp target enter data map(to: y, z)
+
+!$omp target
+ if (allocated(y%b)) stop 8
+ if (allocated(z%b)) stop 9
+!$omp end target
+
+allocate(y%b(5), z%b(3))
+y%b = 42
+z%b = 99
+
+! (implicitly) 'tofrom' mapped
+! Planned for OpenMP 6.0 (but common extension)
+! OpenMP <= 5.0 unclear
+!$omp target
+ if (.not.allocated(y%b)) stop 10
+ if (any (y%b /= 42)) stop 11
+!$omp end target
+
+! always map: OpenMP 5.1 (clarified)
+!$omp target map(always, tofrom: z)
+ if (.not.allocated(z%b)) stop 12
+ if (any (z%b /= 99)) stop 13
+!$omp end target
+
+end
--- /dev/null
+! NOTE: This code uses POINTER.
+! While map(p, var%p) etc. maps the ptr/ptr comp p / var%p (incl. allocatable comps),
+! map(var) does not map var%p.
+
+use iso_c_binding
+implicit none
+type t2
+ integer, allocatable :: x, y, z
+end type t2
+type t
+ integer, pointer :: A => null()
+ integer, pointer :: B(:) => null()
+ type(t2), pointer :: C => null()
+ type(t2), pointer :: D(:,:) => null()
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+integer(c_intptr_t) :: iptr
+
+! --------------------------------------
+! Assign + allocate
+allocate (var%A, source=45)
+allocate (var%B(3), source=[1,2,3])
+allocate (var%C)
+var%C%x = 6; var%C%y = 5; var%C%z = 4
+allocate (var%D(2,2))
+var%D(1,1)%x = 1
+var%D(1,1)%y = 2
+var%D(1,1)%z = 3
+var%D(2,1)%x = 4
+var%D(2,1)%y = 5
+var%D(2,1)%z = 6
+var%D(1,2)%x = 11
+var%D(1,2)%y = 12
+var%D(1,2)%z = 13
+var%D(2,2)%x = 14
+var%D(2,2)%y = 15
+var%D(2,2)%z = 16
+
+! Assign + allocate
+allocate (var2%A, source=145)
+allocate (var2%B, source=[991,992,993])
+allocate (var2%C)
+var2%C%x = 996; var2%C%y = 995; var2%C%z = 994
+allocate (var2%D(2,2))
+var2%D(1,1)%x = 199
+var2%D(1,1)%y = 299
+var2%D(1,1)%z = 399
+var2%D(2,1)%x = 499
+var2%D(2,1)%y = 599
+var2%D(2,1)%z = 699
+var2%D(1,2)%x = 1199
+var2%D(1,2)%y = 1299
+var2%D(1,2)%z = 1399
+var2%D(2,2)%x = 1499
+var2%D(2,2)%y = 1599
+var2%D(2,2)%z = 1699
+
+block
+ integer(c_intptr_t) :: loc_a, loc_b, loc_c, loc_d, loc2_a, loc2_b, loc2_c, loc2_d
+ loc_a = loc (var%a)
+ loc_b = loc (var%b)
+ loc_c = loc (var%d)
+ loc_d = loc (var%d)
+ loc2_a = loc (var2%a)
+ loc2_b = loc (var2%b)
+ loc2_c = loc (var2%c)
+ loc2_d = loc (var2%d)
+ ! var/var2 are mapped, but the pointer components aren't
+ !$omp target map(to: var) map(tofrom: var2)
+ if (loc_a /= loc (var%a)) stop 31
+ if (loc_b /= loc (var%b)) stop 32
+ if (loc_c /= loc (var%d)) stop 33
+ if (loc_d /= loc (var%d)) stop 34
+ if (loc2_a /= loc (var2%a)) stop 35
+ if (loc2_b /= loc (var2%b)) stop 36
+ if (loc2_c /= loc (var2%c)) stop 37
+ if (loc2_d /= loc (var2%d)) stop 38
+ !$omp end target
+ if (loc_a /= loc (var%a)) stop 41
+ if (loc_b /= loc (var%b)) stop 42
+ if (loc_c /= loc (var%d)) stop 43
+ if (loc_d /= loc (var%d)) stop 44
+ if (loc2_a /= loc (var2%a)) stop 45
+ if (loc2_b /= loc (var2%b)) stop 46
+ if (loc2_c /= loc (var2%c)) stop 47
+ if (loc2_d /= loc (var2%d)) stop 48
+end block
+
+block
+ ! Map only (all) components, but this maps also the alloc comps
+ !$omp target map(to: var%a, var%b, var%c, var%d) map(tofrom: var2%a, var2%b, var2%c, var2%d)
+ call foo (var,var2)
+ !$omp end target
+end block
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var2%D(i,j)%x /= tmp_x(i,j)) stop 12
+ if (var2%D(i,j)%y /= tmp_y(i,j)) stop 12
+ if (var2%D(i,j)%z /= tmp_z(i,j)) stop 12
+ end do
+ end do
+end block
+
+! Extra deallocates due to PR fortran/104697
+deallocate(var%C%x, var%C%y, var%C%z)
+deallocate(var%D(1,1)%x, var%D(1,1)%y, var%D(1,1)%z)
+deallocate(var%D(2,1)%x, var%D(2,1)%y, var%D(2,1)%z)
+deallocate(var%D(1,2)%x, var%D(1,2)%y, var%D(1,2)%z)
+deallocate(var%D(2,2)%x, var%D(2,2)%y, var%D(2,2)%z)
+deallocate(var%A, var%B, var%C, var%D)
+
+deallocate(var2%C%x, var2%C%y, var2%C%z)
+deallocate(var2%D(1,1)%x, var2%D(1,1)%y, var2%D(1,1)%z)
+deallocate(var2%D(2,1)%x, var2%D(2,1)%y, var2%D(2,1)%z)
+deallocate(var2%D(1,2)%x, var2%D(1,2)%y, var2%D(1,2)%z)
+deallocate(var2%D(2,2)%x, var2%D(2,2)%y, var2%D(2,2)%z)
+deallocate(var2%A, var2%B, var2%C, var2%D)
+
+! --------------------------------------
+! Assign + allocate
+allocate (var3%Q%A, source=45)
+allocate (var3%Q%B, source=[1,2,3])
+allocate (var3%Q%C, source=t2(6,5,4))
+allocate (var3%Q%D(2,2))
+var3%Q%D(1,1) = t2(1,2,3)
+var3%Q%D(2,1) = t2(4,5,6)
+var3%Q%D(1,2) = t2(11,12,13)
+var3%Q%D(2,2) = t2(14,15,16)
+
+allocate (var3%R(2)%A, source=45)
+allocate (var3%R(2)%B, source=[1,2,3])
+allocate (var3%R(2)%C, source=t2(6,5,4))
+allocate (var3%R(2)%D(2,2))
+var3%R(2)%D(1,1) = t2(1,2,3)
+var3%R(2)%D(2,1) = t2(4,5,6)
+var3%R(2)%D(1,2) = t2(11,12,13)
+var3%R(2)%D(2,2) = t2(14,15,16)
+
+! Assign + allocate
+allocate (var4%Q%A, source=145)
+allocate (var4%Q%B, source=[991,992,993])
+allocate (var4%Q%C, source=t2(996,995,994))
+allocate (var4%Q%D(2,2))
+var4%Q%D(1,1) = t2(199,299,399)
+var4%Q%D(2,1) = t2(499,599,699)
+var4%Q%D(1,2) = t2(1199,1299,1399)
+var4%Q%D(2,2) = t2(1499,1599,1699)
+
+allocate (var4%R(3)%A, source=145)
+allocate (var4%R(3)%B, source=[991,992,993])
+allocate (var4%R(3)%C, source=t2(996,995,994))
+allocate (var4%R(3)%D(2,2))
+var4%R(3)%D(1,1) = t2(199,299,399)
+var4%R(3)%D(2,1) = t2(499,599,699)
+var4%R(3)%D(1,2) = t2(1199,1299,1399)
+var4%R(3)%D(2,2) = t2(1499,1599,1699)
+
+!$omp target map(to: var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D) &
+!$omp& map(tofrom: var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+iptr = loc(var3%R(2)%A)
+
+!$omp target map(to: var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D) &
+!$omp& map(tofrom: var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var4%Q%D(i,j)%x /= tmp_x(i,j)) stop 16
+ if (var4%Q%D(i,j)%y /= tmp_y(i,j)) stop 16
+ if (var4%Q%D(i,j)%z /= tmp_z(i,j)) stop 16
+ end do
+ end do
+end block
+
+! Cf. PR fortran/104696
+! { dg-output "valid mapping, OK" { xfail { offload_device_nonshared_as } } }
+if (iptr /= loc(var3%R(2)%A)) then
+ print *, "invalid mapping, cf. PR fortran/104696"
+else
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var4%R(3)%D(i,j)%x /= tmp_x(i,j)) stop 20
+ if (var4%R(3)%D(i,j)%y /= tmp_y(i,j)) stop 20
+ if (var4%R(3)%D(i,j)%z /= tmp_z(i,j)) stop 20
+ end do
+ end do
+end block
+
+! Extra deallocates due to PR fortran/104697
+deallocate(var3%Q%C%x, var3%Q%D(1,1)%x, var3%Q%D(2,1)%x, var3%Q%D(1,2)%x, var3%Q%D(2,2)%x)
+deallocate(var3%Q%C%y, var3%Q%D(1,1)%y, var3%Q%D(2,1)%y, var3%Q%D(1,2)%y, var3%Q%D(2,2)%y)
+deallocate(var3%Q%C%z, var3%Q%D(1,1)%z, var3%Q%D(2,1)%z, var3%Q%D(1,2)%z, var3%Q%D(2,2)%z)
+deallocate(var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D)
+
+deallocate(var4%Q%C%x, var4%Q%D(1,1)%x, var4%Q%D(2,1)%x, var4%Q%D(1,2)%x, var4%Q%D(2,2)%x)
+deallocate(var4%Q%C%y, var4%Q%D(1,1)%y, var4%Q%D(2,1)%y, var4%Q%D(1,2)%y, var4%Q%D(2,2)%y)
+deallocate(var4%Q%C%z, var4%Q%D(1,1)%z, var4%Q%D(2,1)%z, var4%Q%D(1,2)%z, var4%Q%D(2,2)%z)
+deallocate(var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+
+deallocate(var3%R(2)%C%x, var3%R(2)%D(1,1)%x, var3%R(2)%D(2,1)%x, var3%R(2)%D(1,2)%x, var3%R(2)%D(2,2)%x)
+deallocate(var3%R(2)%C%y, var3%R(2)%D(1,1)%y, var3%R(2)%D(2,1)%y, var3%R(2)%D(1,2)%y, var3%R(2)%D(2,2)%y)
+deallocate(var3%R(2)%C%z, var3%R(2)%D(1,1)%z, var3%R(2)%D(2,1)%z, var3%R(2)%D(1,2)%z, var3%R(2)%D(2,2)%z)
+deallocate(var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D)
+
+deallocate(var4%R(3)%C%x, var4%R(3)%D(1,1)%x, var4%R(3)%D(2,1)%x, var4%R(3)%D(1,2)%x, var4%R(3)%D(2,2)%x)
+deallocate(var4%R(3)%C%y, var4%R(3)%D(1,1)%y, var4%R(3)%D(2,1)%y, var4%R(3)%D(1,2)%y, var4%R(3)%D(2,2)%y)
+deallocate(var4%R(3)%C%z, var4%R(3)%D(1,1)%z, var4%R(3)%D(2,1)%z, var4%R(3)%D(1,2)%z, var4%R(3)%D(2,2)%z)
+deallocate(var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+
+ print *, "valid mapping, OK"
+endif
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ intent(in) :: x
+ intent(inout) :: y
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (x%D(i,j)%x /= tmp_x(i,j)) stop 4
+ if (x%D(i,j)%y /= tmp_y(i,j)) stop 4
+ if (x%D(i,j)%z /= tmp_z(i,j)) stop 4
+ end do
+ end do
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ tmp_x = reshape([199, 499, 1199, 1499], [2,2])
+ tmp_y = reshape([299, 599, 1299, 1599], [2,2])
+ tmp_z = reshape([399, 699, 1399, 1699], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (y%D(i,j)%x /= tmp_x(i,j)) stop 8
+ if (y%D(i,j)%y /= tmp_y(i,j)) stop 8
+ if (y%D(i,j)%z /= tmp_z(i,j)) stop 8
+ end do
+ end do
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C%x = x%C%x
+ y%C%y = x%C%y
+ y%C%z = x%C%z
+ do j = 1, 2
+ do i = 1, 2
+ y%D(i,j)%x = x%D(i,j)%x
+ y%D(i,j)%y = x%D(i,j)%y
+ y%D(i,j)%z = x%D(i,j)%z
+ end do
+ end do
+ end
+end
--- /dev/null
+module m
+ implicit none (type, external)
+ type t
+ integer, allocatable :: arr(:,:)
+ integer :: var
+ integer, allocatable :: slr
+ end type t
+
+contains
+
+ subroutine check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ type(t), intent(inout) :: &
+ scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:), &
+ a_opt_scalar, a_opt_array(:,:), &
+ l_scalar, l_array(:,:), la_scalar, la_array(:,:)
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ logical, value :: is_present, dummy_alloced, inner_alloc
+ integer :: i, j, k, l
+
+ ! CHECK VALUE
+ if (scalar%var /= 42) stop 1
+ if (l_scalar%var /= 42) stop 1
+ if (is_present) then
+ if (opt_scalar%var /= 42) stop 2
+ end if
+ if (any (shape(array) /= [3,2])) stop 1
+ if (any (shape(l_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%var /= i*97 + 100*41*j) stop 3
+ if (l_array(i,j)%var /= i*97 + 100*41*j) stop 3
+ if (is_present) then
+ if (opt_array(i,j)%var /= i*97 + 100*41*j) stop 4
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ if (a_scalar%var /= 42) stop 1
+ if (la_scalar%var /= 42) stop 1
+ if (is_present) then
+ if (a_opt_scalar%var /= 42) stop 1
+ end if
+ if (any (shape(a_array) /= [3,2])) stop 1
+ if (any (shape(la_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(a_opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (a_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ if (la_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ if (is_present) then
+ if (a_opt_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ end if
+ end do
+ end do
+ else
+ if (allocated (a_scalar)) stop 1
+ if (allocated (la_scalar)) stop 1
+ if (allocated (a_array)) stop 1
+ if (allocated (la_array)) stop 1
+ if (is_present) then
+ if (allocated (a_opt_scalar)) stop 1
+ if (allocated (a_opt_array)) stop 1
+ end if
+ end if
+
+ if (inner_alloc) then
+ if (scalar%slr /= 467) stop 5
+ if (l_scalar%slr /= 467) stop 5
+ if (a_scalar%slr /= 467) stop 6
+ if (la_scalar%slr /= 467) stop 6
+ if (is_present) then
+ if (opt_scalar%slr /= 467) stop 7
+ if (a_opt_scalar%slr /= 467) stop 8
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 9
+ if (l_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 9
+ if (a_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 10
+ if (la_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 10
+ if (is_present) then
+ if (opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 11
+ if (a_opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 12
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ if (any (shape(scalar%arr) /= [4,5])) stop 1
+ if (any (shape(l_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(la_scalar%arr) /= [4,5])) stop 1
+ if (scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 13
+ if (l_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 13
+ if (a_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 14
+ if (la_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 14
+ if (is_present) then
+ if (any (shape(opt_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_opt_scalar%arr) /= [4,5])) stop 1
+ if (opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 15
+ if (a_opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 16
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ if (any (shape(array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(l_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(la_array(i,j)%arr) /= [i,j])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_opt_array(i,j)%arr) /= [i,j])) stop 1
+ endif
+ do l = 1, j
+ do k = 1, i
+ if (array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 17
+ if (l_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 17
+ if (a_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 18
+ if (la_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 18
+ if (is_present) then
+ if (opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 19
+ if (a_opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 20
+ end if
+ end do
+ end do
+ end do
+ end do
+ else if (dummy_alloced) then
+ if (allocated (scalar%slr)) stop 1
+ if (allocated (l_scalar%slr)) stop 1
+ if (allocated (a_scalar%slr)) stop 1
+ if (allocated (la_scalar%slr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%slr)) stop 1
+ if (allocated (a_opt_scalar%slr)) stop 1
+ endif
+ if (allocated (scalar%arr)) stop 1
+ if (allocated (l_scalar%arr)) stop 1
+ if (allocated (a_scalar%arr)) stop 1
+ if (allocated (la_scalar%arr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%arr)) stop 1
+ if (allocated (a_opt_scalar%arr)) stop 1
+ endif
+ end if
+
+ ! SET VALUE
+ scalar%var = 42 + 13
+ l_scalar%var = 42 + 13
+ if (is_present) then
+ opt_scalar%var = 42 + 13
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j + 13
+ l_array(i,j)%var = i*97 + 100*41*j + 13
+ if (is_present) then
+ opt_array(i,j)%var = i*97 + 100*41*j + 13
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ a_scalar%var = 42 + 13
+ la_scalar%var = 42 + 13
+ if (is_present) then
+ a_opt_scalar%var = 42 + 13
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j + 13
+ la_array(i,j)%var = i*97 + 100*41*j + 13
+ if (is_present) then
+ a_opt_array(i,j)%var = i*97 + 100*41*j + 13
+ endif
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ scalar%slr = 467 + 13
+ l_scalar%slr = 467 + 13
+ a_scalar%slr = 467 + 13
+ la_scalar%slr = 467 + 13
+ if (is_present) then
+ opt_scalar%slr = 467 + 13
+ a_opt_scalar%slr = 467 + 13
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ if (is_present) then
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ if (is_present) then
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ if (is_present) then
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ end if
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine
+ subroutine check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ type(t), intent(inout) :: &
+ scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:), &
+ a_opt_scalar, a_opt_array(:,:), &
+ l_scalar, l_array(:,:), la_scalar, la_array(:,:)
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ logical, value :: is_present, dummy_alloced, inner_alloc
+ integer :: i, j, k, l
+
+ ! CHECK VALUE
+ if (scalar%var /= 42 + 13) stop 1
+ if (l_scalar%var /= 42 + 13) stop 1
+ if (is_present) then
+ if (opt_scalar%var /= 42 + 13) stop 2
+ end if
+ if (any (shape(array) /= [3,2])) stop 1
+ if (any (shape(l_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%var /= i*97 + 100*41*j + 13) stop 3
+ if (l_array(i,j)%var /= i*97 + 100*41*j + 13) stop 3
+ if (is_present) then
+ if (opt_array(i,j)%var /= i*97 + 100*41*j + 13) stop 4
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ if (a_scalar%var /= 42 + 13) stop 1
+ if (la_scalar%var /= 42 + 13) stop 1
+ if (is_present) then
+ if (a_opt_scalar%var /= 42 + 13) stop 1
+ end if
+ if (any (shape(a_array) /= [3,2])) stop 1
+ if (any (shape(la_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(a_opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (a_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ if (la_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ if (is_present) then
+ if (a_opt_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ end if
+ end do
+ end do
+ else
+ if (allocated (a_scalar)) stop 1
+ if (allocated (la_scalar)) stop 1
+ if (allocated (a_array)) stop 1
+ if (allocated (la_array)) stop 1
+ if (is_present) then
+ if (allocated (a_opt_scalar)) stop 1
+ if (allocated (a_opt_array)) stop 1
+ end if
+ end if
+
+ if (inner_alloc) then
+ if (scalar%slr /= 467 + 13) stop 5
+ if (l_scalar%slr /= 467 + 13) stop 5
+ if (a_scalar%slr /= 467 + 13) stop 6
+ if (la_scalar%slr /= 467 + 13) stop 6
+ if (is_present) then
+ if (opt_scalar%slr /= 467 + 13) stop 7
+ if (a_opt_scalar%slr /= 467 + 13) stop 8
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 9
+ if (l_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 9
+ if (a_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 10
+ if (la_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 10
+ if (is_present) then
+ if (opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 11
+ if (a_opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 12
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ if (any (shape(scalar%arr) /= [4,5])) stop 1
+ if (any (shape(l_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(la_scalar%arr) /= [4,5])) stop 1
+ if (scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 13
+ if (l_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 13
+ if (a_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 14
+ if (la_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 14
+ if (is_present) then
+ if (any (shape(opt_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_opt_scalar%arr) /= [4,5])) stop 1
+ if (opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 15
+ if (a_opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 16
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ if (any (shape(array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(l_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(la_array(i,j)%arr) /= [i,j])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_opt_array(i,j)%arr) /= [i,j])) stop 1
+ endif
+ do l = 1, j
+ do k = 1, i
+ if (array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 17
+ if (l_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 17
+ if (a_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 18
+ if (la_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 18
+ if (is_present) then
+ if (opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 19
+ if (a_opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 20
+ end if
+ end do
+ end do
+ end do
+ end do
+ else if (dummy_alloced) then
+ if (allocated (scalar%slr)) stop 1
+ if (allocated (l_scalar%slr)) stop 1
+ if (allocated (a_scalar%slr)) stop 1
+ if (allocated (la_scalar%slr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%slr)) stop 1
+ if (allocated (a_opt_scalar%slr)) stop 1
+ endif
+ if (allocated (scalar%arr)) stop 1
+ if (allocated (l_scalar%arr)) stop 1
+ if (allocated (a_scalar%arr)) stop 1
+ if (allocated (la_scalar%arr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%arr)) stop 1
+ if (allocated (a_opt_scalar%arr)) stop 1
+ endif
+ end if
+
+ ! (RE)SET VALUE
+ scalar%var = 42
+ l_scalar%var = 42
+ if (is_present) then
+ opt_scalar%var = 42
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j
+ l_array(i,j)%var = i*97 + 100*41*j
+ if (is_present) then
+ opt_array(i,j)%var = i*97 + 100*41*j
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ a_scalar%var = 42
+ la_scalar%var = 42
+ if (is_present) then
+ a_opt_scalar%var = 42
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j
+ la_array(i,j)%var = i*97 + 100*41*j
+ if (is_present) then
+ a_opt_array(i,j)%var = i*97 + 100*41*j
+ endif
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ scalar%slr = 467
+ l_scalar%slr = 467
+ a_scalar%slr = 467
+ la_scalar%slr = 467
+ if (is_present) then
+ opt_scalar%slr = 467
+ a_opt_scalar%slr = 467
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ if (is_present) then
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ if (is_present) then
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ if (is_present) then
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end if
+ end do
+ end do
+ end do
+ end do
+ end if
+ end subroutine
+
+ subroutine test(scalar, array, a_scalar, a_array, opt_scalar, opt_array, &
+ a_opt_scalar, a_opt_array)
+ type(t) :: scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:)
+ type(t) :: a_opt_scalar, a_opt_array(:,:)
+ type(t) :: l_scalar, l_array(3,2), la_scalar, la_array(:,:)
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+
+ integer :: i, j, k, l
+ logical :: is_present, dummy_alloced, local_alloced, inner_alloc
+ is_present = present(opt_scalar)
+ dummy_alloced = allocated(a_scalar)
+ inner_alloc = allocated(scalar%slr)
+
+ l_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ if (dummy_alloced) then
+ allocate(la_scalar, la_array(3,2))
+ a_scalar%var = 42
+ la_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%var = i*97 + 100*41*j
+ la_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ l_scalar%slr = 467
+ la_scalar%slr = 467
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end do
+ end do
+
+ allocate(l_scalar%arr(4,5), la_scalar%arr(4,5))
+ do l = 1, 5
+ do k = 1, 4
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ allocate(l_array(i,j)%arr(i,j), la_array(i,j)%arr(i,j))
+ do l = 1, j
+ do k = 1, i
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ ! implicit mapping
+ !$omp target
+ if (is_present) then
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ end if
+ !$omp end target
+
+ if (is_present) then
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+
+ ! explicit mapping
+ !$omp target map(scalar, array, opt_scalar, opt_array, a_scalar, a_array) &
+ !$omp& map(a_opt_scalar, a_opt_array) &
+ !$omp& map(l_scalar, l_array, la_scalar, la_array)
+ if (is_present) then
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+ !$omp end target
+
+ if (is_present) then
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+ end subroutine
+end module
+
+program main
+ use m
+ implicit none (type, external)
+ type(t) :: scalar, array(3,2), opt_scalar, opt_array(3,2), a_scalar, a_array(:,:)
+ type(t) :: a_opt_scalar, a_opt_array(:,:)
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array
+ integer :: i, j, k, l, n
+
+ scalar%var = 42
+ opt_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j
+ opt_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ ! unallocated
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ ! allocated
+ allocate(a_scalar, a_opt_scalar, a_array(3,2), a_opt_array(3,2))
+ a_scalar%var = 42
+ a_opt_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j
+ a_opt_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ ! comps allocated
+ scalar%slr = 467
+ a_scalar%slr = 467
+ opt_scalar%slr = 467
+ a_opt_scalar%slr = 467
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end do
+ end do
+
+ allocate(scalar%arr(4,5), a_scalar%arr(4,5), opt_scalar%arr(4,5), a_opt_scalar%arr(4,5))
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ allocate(array(i,j)%arr(i,j), a_array(i,j)%arr(i,j), opt_array(i,j)%arr(i,j), a_opt_array(i,j)%arr(i,j))
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end do
+ end do
+ end do
+ end do
+
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ deallocate(a_scalar, a_opt_scalar, a_array, a_opt_array)
+end
--- /dev/null
+module m
+ implicit none (type, external)
+ type t
+ integer, allocatable :: A(:)
+ end type t
+ type t2
+ type(t), allocatable :: vT
+ integer, allocatable :: x
+ end type t2
+
+contains
+
+ subroutine test_alloc()
+ type(t) :: var
+ type(t), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%A(4), var2%A(5))
+
+ !$omp target enter data map(alloc: var, var2)
+ !$omp target
+ if (.not. allocated(Var2)) stop 1
+ if (.not. allocated(Var%A)) stop 2
+ if (.not. allocated(Var2%A)) stop 3
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5
+ var%A = [1,2,3,4]
+ var2%A = [11,22,33,44,55]
+ !$omp end target
+ !$omp target exit data map(from: var, var2)
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%A)) error stop
+ if (.not. allocated(Var2%A)) error stop
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop
+ if (any(var%A /= [1,2,3,4])) error stop
+ if (any(var2%A /= [11,22,33,44,55])) error stop
+ end subroutine test_alloc
+
+ subroutine test2_alloc()
+ type(t2) :: var
+ type(t2), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%x, var2%x)
+
+ !$omp target enter data map(alloc: var, var2)
+ !$omp target
+ if (.not. allocated(Var2)) stop 6
+ if (.not. allocated(Var%x)) stop 7
+ if (.not. allocated(Var2%x)) stop 8
+ var%x = 42
+ var2%x = 43
+ !$omp end target
+ !$omp target exit data map(from: var, var2)
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+ if (var%x /= 42) error stop
+ if (var2%x /= 43) error stop
+
+ allocate(var%vt, var2%vt)
+ allocate(var%vt%A(-1:3), var2%vt%A(0:4))
+
+ !$omp target enter data map(alloc: var, var2)
+ !$omp target
+ if (.not. allocated(Var2)) stop 11
+ if (.not. allocated(Var%x)) stop 12
+ if (.not. allocated(Var2%x)) stop 13
+ if (.not. allocated(Var%vt)) stop 14
+ if (.not. allocated(Var2%vt)) stop 15
+ if (.not. allocated(Var%vt%a)) stop 16
+ if (.not. allocated(Var2%vt%a)) stop 17
+ var%x = 42
+ var2%x = 43
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5
+ var%vt%A = [1,2,3,4,5]
+ var2%vt%A = [11,22,33,44,55]
+ !$omp end target
+ !$omp target exit data map(from: var, var2)
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+ if (.not. allocated(Var%vt)) error stop
+ if (.not. allocated(Var2%vt)) error stop
+ if (.not. allocated(Var%vt%a)) error stop
+ if (.not. allocated(Var2%vt%a)) error stop
+ if (var%x /= 42) error stop
+ if (var2%x /= 43) error stop
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop
+ if (any(var%vt%A /= [1,2,3,4,5])) error stop
+ if (any(var2%vt%A /= [11,22,33,44,55])) error stop
+ end subroutine test2_alloc
+
+
+ subroutine test_alloc_target()
+ type(t) :: var
+ type(t), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%A(4), var2%A(5))
+
+ !$omp target map(alloc: var, var2)
+ if (.not. allocated(Var2)) stop 1
+ if (.not. allocated(Var%A)) stop 2
+ if (.not. allocated(Var2%A)) stop 3
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5
+ var%A = [1,2,3,4]
+ var2%A = [11,22,33,44,55]
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%A)) error stop
+ if (.not. allocated(Var2%A)) error stop
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop
+ end subroutine test_alloc_target
+
+ subroutine test2_alloc_target()
+ type(t2) :: var
+ type(t2), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%x, var2%x)
+
+ !$omp target map(alloc: var, var2)
+ if (.not. allocated(Var2)) stop 6
+ if (.not. allocated(Var%x)) stop 7
+ if (.not. allocated(Var2%x)) stop 8
+ var%x = 42
+ var2%x = 43
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+
+ allocate(var%vt, var2%vt)
+ allocate(var%vt%A(-1:3), var2%vt%A(0:4))
+
+ !$omp target map(alloc: var, var2)
+ if (.not. allocated(Var2)) stop 11
+ if (.not. allocated(Var%x)) stop 12
+ if (.not. allocated(Var2%x)) stop 13
+ if (.not. allocated(Var%vt)) stop 14
+ if (.not. allocated(Var2%vt)) stop 15
+ if (.not. allocated(Var%vt%a)) stop 16
+ if (.not. allocated(Var2%vt%a)) stop 17
+ var%x = 42
+ var2%x = 43
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5
+ var%vt%A = [1,2,3,4,5]
+ var2%vt%A = [11,22,33,44,55]
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+ if (.not. allocated(Var%vt)) error stop
+ if (.not. allocated(Var2%vt)) error stop
+ if (.not. allocated(Var%vt%a)) error stop
+ if (.not. allocated(Var2%vt%a)) error stop
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop
+ end subroutine test2_alloc_target
+
+
+
+ subroutine test_from()
+ type(t) :: var
+ type(t), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%A(4), var2%A(5))
+
+ !$omp target map(from: var, var2)
+ if (.not. allocated(Var2)) stop 1
+ if (.not. allocated(Var%A)) stop 2
+ if (.not. allocated(Var2%A)) stop 3
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5
+ var%A = [1,2,3,4]
+ var2%A = [11,22,33,44,55]
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%A)) error stop
+ if (.not. allocated(Var2%A)) error stop
+ if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop
+ if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop
+ if (any(var%A /= [1,2,3,4])) error stop
+ if (any(var2%A /= [11,22,33,44,55])) error stop
+ end subroutine test_from
+
+ subroutine test2_from()
+ type(t2) :: var
+ type(t2), allocatable :: var2
+
+ allocate(var2)
+ allocate(var%x, var2%x)
+
+ !$omp target map(from: var, var2)
+ if (.not. allocated(Var2)) stop 6
+ if (.not. allocated(Var%x)) stop 7
+ if (.not. allocated(Var2%x)) stop 8
+ var%x = 42
+ var2%x = 43
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+ if (var%x /= 42) error stop
+ if (var2%x /= 43) error stop
+
+ allocate(var%vt, var2%vt)
+ allocate(var%vt%A(-1:3), var2%vt%A(0:4))
+
+ !$omp target map(from: var, var2)
+ if (.not. allocated(Var2)) stop 11
+ if (.not. allocated(Var%x)) stop 12
+ if (.not. allocated(Var2%x)) stop 13
+ if (.not. allocated(Var%vt)) stop 14
+ if (.not. allocated(Var2%vt)) stop 15
+ if (.not. allocated(Var%vt%a)) stop 16
+ if (.not. allocated(Var2%vt%a)) stop 17
+ var%x = 42
+ var2%x = 43
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5
+ var%vt%A = [1,2,3,4,5]
+ var2%vt%A = [11,22,33,44,55]
+ !$omp end target
+
+ if (.not. allocated(Var2)) error stop
+ if (.not. allocated(Var%x)) error stop
+ if (.not. allocated(Var2%x)) error stop
+ if (.not. allocated(Var%vt)) error stop
+ if (.not. allocated(Var2%vt)) error stop
+ if (.not. allocated(Var%vt%a)) error stop
+ if (.not. allocated(Var2%vt%a)) error stop
+ if (var%x /= 42) error stop
+ if (var2%x /= 43) error stop
+ if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop
+ if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop
+ if (any(var%vt%A /= [1,2,3,4,5])) error stop
+ if (any(var2%vt%A /= [11,22,33,44,55])) error stop
+ end subroutine test2_from
+
+end module m
+
+use m
+ implicit none (type, external)
+ call test_alloc
+ call test2_alloc
+ call test_alloc_target
+ call test2_alloc_target
+
+ call test_from
+ call test2_from
+end
--- /dev/null
+! Ensure that polymorphic mapping is diagnosed as undefined behavior
+! Ensure that static access to polymorphic variables works
+
+subroutine test(case)
+implicit none(type, external)
+type t
+ integer :: x(4)
+end type t
+
+type ta
+ integer, allocatable :: x(:)
+end type ta
+
+type t2
+ class(t), allocatable :: x
+ class(t), allocatable :: x2(:)
+end type t2
+
+type t3
+ type(t2) :: y
+ type(t2) :: y2(2)
+end type t3
+
+type t4
+ type(t3), allocatable :: y
+ type(t3), allocatable :: y2(:)
+end type t4
+
+integer, value :: case
+
+logical :: is_shared_mem
+
+! Mangle stack addresses
+integer, volatile :: case_var(100*case)
+
+type(t), allocatable :: var1
+type(ta), allocatable :: var1a
+class(t), allocatable :: var2
+type(t2), allocatable :: var3
+type(t4), allocatable :: var4
+
+case_var(100) = 0
+!print *, 'case', case
+
+var1 = t([1,2,3,4])
+var1a = ta([-1,-2,-3,-4,-5])
+
+var2 = t([11,22,33,44])
+
+allocate(t2 :: var3)
+allocate(t :: var3%x)
+allocate(t :: var3%x2(2))
+var3%x%x = [111,222,333,444]
+var3%x2(1)%x = 2*[111,222,333,444]
+var3%x2(2)%x = 3*[111,222,333,444]
+
+allocate(t4 :: var4)
+allocate(t3 :: var4%y)
+allocate(t3 :: var4%y2(2))
+allocate(t :: var4%y%y%x)
+allocate(t :: var4%y%y%x2(2))
+allocate(t :: var4%y2(1)%y%x)
+allocate(t :: var4%y2(1)%y%x2(2))
+allocate(t :: var4%y2(2)%y%x)
+allocate(t :: var4%y2(2)%y%x2(2))
+var4%y%y%x%x = -1 * [1111,2222,3333,4444]
+var4%y%y%x2(1)%x = -2 * [1111,2222,3333,4444]
+var4%y%y%x2(2)%x = -3 * [1111,2222,3333,4444]
+var4%y2(1)%y%x%x = -4 * [1111,2222,3333,4444]
+var4%y2(1)%y%x2(1)%x = -5 * [1111,2222,3333,4444]
+var4%y2(1)%y%x2(2)%x = -6 * [1111,2222,3333,4444]
+var4%y2(2)%y%x%x = -7 * [1111,2222,3333,4444]
+var4%y2(2)%y%x2(1)%x = -8 * [1111,2222,3333,4444]
+var4%y2(2)%y%x2(2)%x = -9 * [1111,2222,3333,4444]
+
+is_shared_mem = .false.
+!$omp target map(to: is_shared_mem)
+ is_shared_mem = .true.
+!$omp end target
+
+if (case == 1) then
+ ! implicit mapping
+ !$omp target
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ end if
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ end if
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+else if (case == 2) then
+ ! Use target with defaultmap(TO)
+
+ !$omp target defaultmap(to : all)
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target defaultmap(to : all)
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target defaultmap(to : all) ! { dg-warning "Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target defaultmap(to : all) ! { dg-warning "Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target defaultmap(to : all) firstprivate(is_shared_mem) ! { dg-warning "Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ endif
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+else if (case == 3) then
+ ! Use target with map clause
+
+ !$omp target map(tofrom: var1)
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target map(tofrom: var1a)
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target map(tofrom: var2) ! { dg-warning "28: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target map(tofrom: var3) ! { dg-warning "28: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target map(tofrom: var4) ! { dg-warning "28: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ end if
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ endif
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+else if (case == 4) then
+ ! Use target with map clause -- NOTE: This uses TO not TOFROM
+
+ !$omp target map(to: var1)
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target map(to: var1a)
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target map(to: var2) ! { dg-warning "24: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target map(to: var3) ! { dg-warning "24: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target map(to: var4) ! { dg-warning "24: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ endif
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+else if (case == 5) then
+ ! Use target enter/exit data + target with explicit map
+ !$omp target enter data map(to: var1)
+ !$omp target enter data map(to: var1a)
+ !$omp target enter data map(to: var2) ! { dg-warning "35: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target enter data map(to: var3) ! { dg-warning "35: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target enter data map(to: var4) ! { dg-warning "35: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+
+ !$omp target map(to: var1)
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target map(to: var1a)
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target map(to: var2) ! { dg-warning "24: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target map(to: var3) ! { dg-warning "24: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target map(to: var4) ! { dg-warning "24: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ endif
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target exit data map(from: var1)
+ !$omp target exit data map(from: var1a)
+ !$omp target exit data map(from: var2) ! { dg-warning "36: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target exit data map(from: var3) ! { dg-warning "36: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target exit data map(from: var4) ! { dg-warning "36: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+
+else if (case == 6) then
+ ! Use target enter/exit data + target with implicit map
+
+ !$omp target enter data map(to: var1)
+ !$omp target enter data map(to: var1a)
+ !$omp target enter data map(to: var2) ! { dg-warning "35: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target enter data map(to: var3) ! { dg-warning "35: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target enter data map(to: var4) ! { dg-warning "35: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+
+ !$omp target
+ if (any (var1%x /= [1,2,3,4])) stop 1
+ var1%x = 2 * var1%x
+ !$omp end target
+
+ !$omp target
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 2
+ var1a%x = 3 * var1a%x
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var2%x /= [11,22,33,44])) stop 3
+ var2%x = 4 * var2%x
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var3%x%x /= [111,222,333,444])) stop 4
+ var3%x%x = 5 * var3%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 4
+ if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 4
+ var3%x2(1)%x = 5 * var3%x2(1)%x
+ var3%x2(2)%x = 5 * var3%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target ! { dg-warning "Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 5
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 5
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 5
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 5
+ endif
+ var4%y%y%x%x = 6 * var4%y%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y%y%x2(1)%x = 6 * var4%y%y%x2(1)%x
+ var4%y%y%x2(2)%x = 6 * var4%y%y%x2(2)%x
+ endif
+ var4%y2(1)%y%x%x = 6 * var4%y2(1)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(1)%y%x2(1)%x = 6 * var4%y2(1)%y%x2(1)%x
+ var4%y2(1)%y%x2(2)%x = 6 * var4%y2(1)%y%x2(2)%x
+ endif
+ var4%y2(2)%y%x%x = 6 * var4%y2(2)%y%x%x
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ var4%y2(2)%y%x2(1)%x = 6 * var4%y2(2)%y%x2(1)%x
+ var4%y2(2)%y%x2(2)%x = 6 * var4%y2(2)%y%x2(2)%x
+ endif
+ !$omp end target
+
+ !$omp target exit data map(from: var1)
+ !$omp target exit data map(from: var1a)
+ !$omp target exit data map(from: var2) ! { dg-warning "36: Mapping of polymorphic list item 'var2' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target exit data map(from: var3) ! { dg-warning "36: Mapping of polymorphic list item 'var3->x' is unspecified behavior \\\[-Wopenmp\\\]" }
+ !$omp target exit data map(from: var4) ! { dg-warning "36: Mapping of polymorphic list item 'var4\.\[0-9\]+->y->y\.x' is unspecified behavior \\\[-Wopenmp\\\]" }
+
+else
+ error stop
+end if
+
+if ((case /= 2 .and. case /= 4) .or. is_shared_mem) then
+ ! The target update should have been active, check for the updated values
+ if (any (var1%x /= 2 * [1,2,3,4])) stop 11
+ if (any (var1a%x /= 3 * [-1,-2,-3,-4])) stop 22
+ if (any (var2%x /= 4 * [11,22,33,44])) stop 33
+
+ if (any (var3%x%x /= 5 * [111,222,333,444])) stop 44
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var3%x2(1)%x /= 2 * 5 * [111,222,333,444])) stop 44
+ if (any (var3%x2(2)%x /= 3 * 5 * [111,222,333,444])) stop 44
+ endif
+
+ if (any (var4%y%y%x%x /= -1 * 6 * [1111,2222,3333,4444])) stop 55
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y%y%x2(1)%x /= -2 * 6 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y%y%x2(2)%x /= -3 * 6 * [1111,2222,3333,4444])) stop 55
+ endif
+ if (any (var4%y2(1)%y%x%x /= -4 * 6 * [1111,2222,3333,4444])) stop 55
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(1)%y%x2(1)%x /= -5 * 6 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y2(1)%y%x2(2)%x /= -6 * 6 * [1111,2222,3333,4444])) stop 55
+ endif
+ if (any (var4%y2(2)%y%x%x /= -7 * 6 * [1111,2222,3333,4444])) stop 55
+ if (is_shared_mem) then ! For stride data, this accesses the host's _vtab
+ if (any (var4%y2(2)%y%x2(1)%x /= -8 * 6 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y2(2)%y%x2(2)%x /= -9 * 6 * [1111,2222,3333,4444])) stop 55
+ endif
+else
+ ! The old host values should still be there as 'to:' created a device copy
+ if (any (var1%x /= [1,2,3,4])) stop 12
+ if (any (var1a%x /= [-1,-2,-3,-4])) stop 22
+ if (any (var2%x /= [11,22,33,44])) stop 33
+
+ if (any (var3%x%x /= [111,222,333,444])) stop 44
+ ! .not. is_shared_mem:
+ ! if (any (var3%x2(1)%x /= 2*[111,222,333,444])) stop 44
+ ! if (any (var3%x2(2)%x /= 3*[111,222,333,444])) stop 44
+
+ if (any (var4%y%y%x%x /= -1 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y%y%x2(1)%x /= -2 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y%y%x2(2)%x /= -3 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y2(1)%y%x%x /= -4 * [1111,2222,3333,4444])) stop 55
+ ! .not. is_shared_mem:
+ !if (any (var4%y2(1)%y%x2(1)%x /= -5 * [1111,2222,3333,4444])) stop 55
+ !if (any (var4%y2(1)%y%x2(2)%x /= -6 * [1111,2222,3333,4444])) stop 55
+ if (any (var4%y2(2)%y%x%x /= -7 * [1111,2222,3333,4444])) stop 55
+ ! .not. is_shared_mem:
+ !if (any (var4%y2(2)%y%x2(1)%x /= -8 * [1111,2222,3333,4444])) stop 55
+ !if (any (var4%y2(2)%y%x2(2)%x /= -9 * [1111,2222,3333,4444])) stop 55
+end if
+if (case_var(100) /= 0) stop 123
+end subroutine test
+
+program main
+ use omp_lib
+ implicit none(type, external)
+ interface
+ subroutine test(case)
+ integer, value :: case
+ end
+ end interface
+ integer :: dev
+ call run_it(omp_get_default_device())
+ do dev = 0, omp_get_num_devices()
+ call run_it(dev)
+ end do
+ call run_it(omp_initial_device)
+! print *, 'all done'
+contains
+subroutine run_it(dev)
+ integer, value :: dev
+! print *, 'DEVICE', dev
+ call omp_set_default_device(dev)
+ call test(1)
+ call test(2)
+ call test(3)
+ call test(4)
+ call test(5)
+ call test(6)
+end
+end
projects / thirdparty / gcc.git / commitdiff
