aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-openmp.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-openmp.c')
-rw-r--r--gcc/fortran/trans-openmp.c192
1 files changed, 111 insertions, 81 deletions
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 249b3de..67e370f 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -2675,6 +2675,32 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree decl = gfc_trans_omp_variable (n->sym, false);
if (DECL_P (decl))
TREE_ADDRESSABLE (decl) = 1;
+
+ gfc_ref *lastref = NULL;
+
+ if (n->expr)
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
+ lastref = ref;
+
+ bool allocatable = false, pointer = false;
+
+ if (lastref && lastref->type == REF_COMPONENT)
+ {
+ gfc_component *c = lastref->u.c.component;
+
+ if (c->ts.type == BT_CLASS)
+ {
+ pointer = CLASS_DATA (c)->attr.class_pointer;
+ allocatable = CLASS_DATA (c)->attr.allocatable;
+ }
+ else
+ {
+ pointer = c->attr.pointer;
+ allocatable = c->attr.allocatable;
+ }
+ }
+
if (n->expr == NULL
|| (n->expr->ref->type == REF_ARRAY
&& n->expr->ref->u.ar.type == AR_FULL))
@@ -2911,74 +2937,79 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
- && n->expr->ref->type == REF_COMPONENT)
+ && n->expr->ref->type == REF_ARRAY
+ && !n->expr->ref->next)
{
- gfc_ref *lastcomp;
-
- for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- lastcomp = ref;
-
- symbol_attribute sym_attr;
-
- if (lastcomp->u.c.component->ts.type == BT_CLASS)
- sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr;
- else
- sym_attr = lastcomp->u.c.component->attr;
-
+ /* An array element or array section which is not part of a
+ derived type, etc. */
+ bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
+ gfc_trans_omp_array_section (block, n, decl, element,
+ GOMP_MAP_POINTER, node, node2,
+ node3, node4);
+ }
+ else if (n->expr
+ && n->expr->expr_type == EXPR_VARIABLE
+ && (n->expr->ref->type == REF_COMPONENT
+ || n->expr->ref->type == REF_ARRAY)
+ && lastref
+ && lastref->type == REF_COMPONENT
+ && lastref->u.c.component->ts.type != BT_CLASS
+ && lastref->u.c.component->ts.type != BT_DERIVED
+ && !lastref->u.c.component->attr.dimension)
+ {
+ /* Derived type access with last component being a scalar. */
gfc_init_se (&se, NULL);
- if (!sym_attr.dimension
- && lastcomp->u.c.component->ts.type != BT_CLASS
- && lastcomp->u.c.component->ts.type != BT_DERIVED)
+ gfc_conv_expr (&se, n->expr);
+ gfc_add_block_to_block (block, &se.pre);
+ /* For BT_CHARACTER a pointer is returned. */
+ OMP_CLAUSE_DECL (node)
+ = POINTER_TYPE_P (TREE_TYPE (se.expr))
+ ? build_fold_indirect_ref (se.expr) : se.expr;
+ gfc_add_block_to_block (block, &se.post);
+ if (pointer || allocatable)
{
- /* Last component is a scalar. */
- gfc_conv_expr (&se, n->expr);
- gfc_add_block_to_block (block, &se.pre);
- /* For BT_CHARACTER a pointer is returned. */
- OMP_CLAUSE_DECL (node)
+ node2 = build_omp_clause (input_location,
+ OMP_CLAUSE_MAP);
+ gomp_map_kind kind
+ = (openacc ? GOMP_MAP_ATTACH_DETACH
+ : GOMP_MAP_ALWAYS_POINTER);
+ OMP_CLAUSE_SET_MAP_KIND (node2, kind);
+ OMP_CLAUSE_DECL (node2)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
- ? build_fold_indirect_ref (se.expr) : se.expr;
- gfc_add_block_to_block (block, &se.post);
- if (sym_attr.pointer || sym_attr.allocatable)
+ ? se.expr
+ : gfc_build_addr_expr (NULL, se.expr);
+ OMP_CLAUSE_SIZE (node2) = size_int (0);
+ if (!openacc
+ && n->expr->ts.type == BT_CHARACTER
+ && n->expr->ts.deferred)
{
- node2 = build_omp_clause (input_location,
+ gcc_assert (se.string_length);
+ tree tmp
+ = gfc_get_char_type (n->expr->ts.kind);
+ OMP_CLAUSE_SIZE (node)
+ = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node,
+ se.string_length),
+ TYPE_SIZE_UNIT (tmp));
+ node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node2,
- openacc
- ? GOMP_MAP_ATTACH_DETACH
- : GOMP_MAP_ALWAYS_POINTER);
- OMP_CLAUSE_DECL (node2)
- = POINTER_TYPE_P (TREE_TYPE (se.expr))
- ? se.expr : gfc_build_addr_expr (NULL, se.expr);
- OMP_CLAUSE_SIZE (node2) = size_int (0);
- if (!openacc
- && n->expr->ts.type == BT_CHARACTER
- && n->expr->ts.deferred)
- {
- gcc_assert (se.string_length);
- tree tmp = gfc_get_char_type (n->expr->ts.kind);
- OMP_CLAUSE_SIZE (node)
- = fold_build2 (MULT_EXPR, size_type_node,
- fold_convert (size_type_node,
- se.string_length),
- TYPE_SIZE_UNIT (tmp));
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
- OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
- OMP_CLAUSE_DECL (node3) = se.string_length;
- OMP_CLAUSE_SIZE (node3)
- = TYPE_SIZE_UNIT (gfc_charlen_type_node);
- }
+ OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
+ OMP_CLAUSE_DECL (node3) = se.string_length;
+ OMP_CLAUSE_SIZE (node3)
+ = TYPE_SIZE_UNIT (gfc_charlen_type_node);
}
- goto finalize_map_clause;
}
-
+ }
+ else if (n->expr
+ && n->expr->expr_type == EXPR_VARIABLE
+ && (n->expr->ref->type == REF_COMPONENT
+ || n->expr->ref->type == REF_ARRAY))
+ {
+ gfc_init_se (&se, NULL);
se.expr = gfc_maybe_dereference_var (n->sym, decl);
- for (gfc_ref *ref = n->expr->ref;
- ref && ref != lastcomp->next;
- ref = ref->next)
+ for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT)
{
@@ -2987,24 +3018,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
gfc_conv_component_ref (&se, ref);
}
+ else if (ref->type == REF_ARRAY)
+ {
+ if (ref->u.ar.type == AR_ELEMENT && ref->next)
+ gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
+ &n->expr->where);
+ else
+ gcc_assert (!ref->next);
+ }
else
- sorry ("unhandled derived-type component");
+ sorry ("unhandled expression type");
}
tree inner = se.expr;
/* Last component is a derived type or class pointer. */
- if (lastcomp->u.c.component->ts.type == BT_DERIVED
- || lastcomp->u.c.component->ts.type == BT_CLASS)
+ if (lastref->type == REF_COMPONENT
+ && (lastref->u.c.component->ts.type == BT_DERIVED
+ || lastref->u.c.component->ts.type == BT_CLASS))
{
- bool pointer
- = (lastcomp->u.c.component->ts.type == BT_CLASS
- ? sym_attr.class_pointer : sym_attr.pointer);
- if (pointer || (openacc && sym_attr.allocatable))
+ if (pointer || (openacc && allocatable))
{
tree data, size;
- if (lastcomp->u.c.component->ts.type == BT_CLASS)
+ if (lastref->u.c.component->ts.type == BT_CLASS)
{
data = gfc_class_data_get (inner);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
@@ -3035,9 +3072,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
= TYPE_SIZE_UNIT (TREE_TYPE (inner));
}
}
- else if (lastcomp->next
- && lastcomp->next->type == REF_ARRAY
- && lastcomp->next->u.ar.type == AR_FULL)
+ else if (lastref->type == REF_ARRAY
+ && lastref->u.ar.type == AR_FULL)
{
/* Just pass the (auto-dereferenced) decl through for
bare attach and detach clauses. */
@@ -3131,27 +3167,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
else
OMP_CLAUSE_DECL (node) = inner;
}
- else /* An array element or section. */
+ else if (lastref->type == REF_ARRAY)
{
- bool element
- = (lastcomp->next
- && lastcomp->next->type == REF_ARRAY
- && lastcomp->next->u.ar.type == AR_ELEMENT);
-
+ /* An array element or section. */
+ bool element = lastref->u.ar.type == AR_ELEMENT;
gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH
: GOMP_MAP_ALWAYS_POINTER);
gfc_trans_omp_array_section (block, n, inner, element,
kind, node, node2, node3,
node4);
}
+ else
+ gcc_unreachable ();
}
- else /* An array element or array section. */
- {
- bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
- gfc_trans_omp_array_section (block, n, decl, element,
- GOMP_MAP_POINTER, node, node2,
- node3, node4);
- }
+ else
+ sorry ("unhandled expression");
finalize_map_clause:
generated by cgit v1.1 at 2025-05-31 02:52:32 +0000