From 95a2a34ce314e1a1b8f8d531035622a64ac707f8 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Wed, 24 Jul 2024 09:39:45 +0200
Subject: [PATCH 2/2] [Fortran] Fix Coarray in associate not a coarray.
[PR110033]
A coarray used in an associate did not become a coarray in the block of
the associate. This patch fixes that and the same also in select type
statements.
PR fortran/110033
gcc/fortran/ChangeLog:
* class.cc (gfc_is_class_scalar_expr): Coarray refs that ref
only self, aka this image, are regarded as scalar, too.
* resolve.cc (resolve_assoc_var): Ignore this image coarray refs
and do not build a new class type.
* trans-expr.cc (gfc_get_caf_token_offset): Get the caf token
from the descriptor for associated variables.
(gfc_conv_variable): Same.
(gfc_trans_pointer_assignment): Assign token to temporary
associate variable, too.
(gfc_trans_scalar_assign): Add flag that assign is for associate
and use it to assign the token.
(is_assoc_assign): Detect that expressions are for associate
assign.
(gfc_trans_assignment_1): Treat associate assigns like pointer
assignments where possible.
* trans-stmt.cc (trans_associate_var): Set same_class only for
class-targets.
* trans.h (gfc_trans_scalar_assign): Add flag to
trans_scalar_assign for marking associate assignments.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/associate_1.f90: New test.
---
gcc/fortran/class.cc | 38 ++++----
gcc/fortran/resolve.cc | 40 ++++++---
gcc/fortran/trans-expr.cc | 87 +++++++++++++++----
gcc/fortran/trans-stmt.cc | 2 +-
gcc/fortran/trans.h | 5 +-
.../gfortran.dg/coarray/associate_1.f90 | 30 +++++++
6 files changed, 157 insertions(+), 45 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/associate_1.f90
@@ -379,27 +379,33 @@ gfc_is_class_scalar_expr (gfc_expr *e)
return false;
/* Is this a class object? */
- if (e->symtree
- && e->symtree->n.sym->ts.type == BT_CLASS
- && CLASS_DATA (e->symtree->n.sym)
- && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
- && (e->ref == NULL
- || (e->ref->type == REF_COMPONENT
- && strcmp (e->ref->u.c.component->name, "_data") == 0
- && e->ref->next == NULL)))
+ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS
+ && CLASS_DATA (e->symtree->n.sym)
+ && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
+ && (e->ref == NULL
+ || (e->ref->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0
+ && (e->ref->next == NULL
+ || (e->ref->next->type == REF_ARRAY
+ && e->ref->next->u.ar.codimen > 0
+ && e->ref->next->u.ar.dimen == 0
+ && e->ref->next->next == NULL)))))
return true;
/* Or is the final reference BT_CLASS or _data? */
for (ref = e->ref; ref; ref = ref->next)
{
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (ref->u.c.component)
- && !CLASS_DATA (ref->u.c.component)->attr.dimension
- && (ref->next == NULL
- || (ref->next->type == REF_COMPONENT
- && strcmp (ref->next->u.c.component->name, "_data") == 0
- && ref->next->next == NULL)))
+ if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS
+ && CLASS_DATA (ref->u.c.component)
+ && !CLASS_DATA (ref->u.c.component)->attr.dimension
+ && (ref->next == NULL
+ || (ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
+ && (ref->next->next == NULL
+ || (ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.codimen > 0
+ && ref->next->next->u.ar.dimen == 0
+ && ref->next->next->next == NULL)))))
return true;
}
@@ -9750,6 +9750,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
correct this now. */
gfc_typespec *ts = &target->ts;
gfc_ref *ref;
+ /* Internal_ref is true, when this is ref'ing only _data and co-ref.
+ */
+ bool internal_ref = true;
for (ref = target->ref; ref != NULL; ref = ref->next)
{
@@ -9757,26 +9760,41 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
case REF_COMPONENT:
ts = &ref->u.c.component->ts;
+ internal_ref
+ = target->ref == ref && ref->next
+ && strncmp ("_data", ref->u.c.component->name, 5) == 0;
break;
case REF_ARRAY:
if (ts->type == BT_CLASS)
ts = &ts->u.derived->components->ts;
+ if (internal_ref && ref->u.ar.codimen > 0)
+ for (int i = ref->u.ar.dimen;
+ internal_ref
+ && i < ref->u.ar.dimen + ref->u.ar.codimen;
+ ++i)
+ internal_ref
+ = ref->u.ar.dimen_type[i] == DIMEN_THIS_IMAGE;
break;
default:
break;
}
}
- /* Create a scalar instance of the current class type. Because the
- rank of a class array goes into its name, the type has to be
- rebuilt. The alternative of (re-)setting just the attributes
- and as in the current type, destroys the type also in other
- places. */
- as = NULL;
- sym->ts = *ts;
- sym->ts.type = BT_CLASS;
- attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
- gfc_change_class (&sym->ts, &attr, as, 0, 0);
- sym->as = NULL;
+ /* Only rewrite the type of this symbol, when the refs are not the
+ internal ones for class and co-array this-image. */
+ if (!internal_ref)
+ {
+ /* Create a scalar instance of the current class type. Because
+ the rank of a class array goes into its name, the type has to
+ be rebuilt. The alternative of (re-)setting just the
+ attributes and as in the current type, destroys the type also
+ in other places. */
+ as = NULL;
+ sym->ts = *ts;
+ sym->ts.type = BT_CLASS;
+ attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr;
+ gfc_change_class (&sym->ts, &attr, as, 0, 0);
+ sym->as = NULL;
+ }
}
}
@@ -2437,7 +2437,8 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
{
gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
== GFC_ARRAY_ALLOCATABLE
- || expr->symtree->n.sym->attr.select_type_temporary);
+ || expr->symtree->n.sym->attr.select_type_temporary
+ || expr->symtree->n.sym->assoc);
*token = gfc_conv_descriptor_token (caf_decl);
}
else if (DECL_LANG_SPECIFIC (caf_decl)
@@ -3256,6 +3257,13 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
else
se->string_length = sym->ts.u.cl->backend_decl;
gcc_assert (se->string_length);
+
+ /* For coarray strings return the pointer to the data and not the
+ descriptor. */
+ if (sym->attr.codimension && sym->attr.associate_var
+ && !se->descriptor_only
+ && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
+ se->expr = gfc_conv_descriptor_data_get (se->expr);
}
/* Some expressions leak through that haven't been fixed up. */
@@ -10536,10 +10544,25 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
- /* Also set the tokens for pointer components in derived typed
- coarrays. */
if (flag_coarray == GFC_FCOARRAY_LIB)
- trans_caf_token_assign (&lse, &rse, expr1, expr2);
+ {
+ if (expr1->ref)
+ /* Also set the tokens for pointer components in derived typed
+ coarrays. */
+ trans_caf_token_assign (&lse, &rse, expr1, expr2);
+ else if (gfc_caf_attr (expr1).codimension)
+ {
+ tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
+
+ lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
+ rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
+ gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
+ NULL_TREE, expr1);
+ gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
+ NULL_TREE, expr2);
+ gfc_add_modify (&block, lhs_tok, rhs_tok);
+ }
+ }
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
@@ -10981,8 +11004,9 @@ gfc_conv_string_parameter (gfc_se * se)
the assignment from the temporary to the lhs. */
tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool deep_copy, bool dealloc, bool in_coarray)
+gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
+ bool deep_copy, bool dealloc, bool in_coarray,
+ bool assoc_assign)
{
stmtblock_t block;
tree tmp;
@@ -11103,6 +11127,21 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ if (in_coarray)
+ {
+ if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
+ {
+ gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
+ TYPE_LANG_SPECIFIC (
+ TREE_TYPE (TREE_TYPE (rse->expr)))
+ ->caf_token);
+ }
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
+ lse->expr = gfc_conv_array_data (lse->expr);
+ if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
+ && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
+ rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
+ }
gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
@@ -12290,6 +12329,15 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+bool
+is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
+{
+ if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
+ return false;
+
+ return lhs->symtree->n.sym->assoc
+ && lhs->symtree->n.sym->assoc->target == rhs;
+}
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
@@ -12323,6 +12371,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
bool realloc_flag;
+ bool assoc_assign = false;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
@@ -12378,6 +12427,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_class_scalar_expr (expr2))
&& lhs_attr.flavor != FL_PROCEDURE;
+ assoc_assign = is_assoc_assign (expr1, expr2);
+
realloc_flag = flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1)
&& expr2->rank
@@ -12471,11 +12522,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
/* Translate the expression. */
- rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
- && lhs_caf_attr.codimension;
+ rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
+ && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
+ rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
gfc_conv_expr (&rse, expr2);
- /* Deal with the case of a scalar class function assigned to a derived type. */
+ /* Deal with the case of a scalar class function assigned to a derived type.
+ */
if (gfc_is_alloc_class_scalar_function (expr2)
&& expr1->ts.type == BT_DERIVED)
{
@@ -12690,15 +12743,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
else
gfc_add_block_to_block (&body, &rse.pre);
+ if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
+ && assoc_assign)
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
+
/* If nothing else works, do it the old fashioned way! */
if (tmp == NULL_TREE)
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- gfc_expr_is_variable (expr2)
- || scalar_to_array
+ tmp
+ = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ gfc_expr_is_variable (expr2) || scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc,
- expr1->symtree->n.sym->attr.codimension);
-
+ !(l_is_temp || init_flag) && dealloc,
+ expr1->symtree->n.sym->attr.codimension,
+ assoc_assign);
/* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
@@ -1754,7 +1754,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& e->ts.type == BT_CLASS
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
- same_class = e->ts.type == BT_CLASS && sym->ts.type == BT_CLASS
+ same_class = class_target && sym->ts.type == BT_CLASS
&& strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0;
unlimited = UNLIMITED_POLY (e);
@@ -570,8 +570,9 @@ void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool,
void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *);
/* Generate code for a scalar assignment. */
-tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
- bool c = false);
+tree
+gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
+ bool = false, bool = false);
/* Translate COMMON blocks. */
void gfc_trans_common (gfc_namespace *);
new file mode 100644
@@ -0,0 +1,30 @@
+!{ dg-do run }
+
+! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
+! Check PR110033 is fixed.
+
+program coarray_associate_1
+ type t
+ integer :: b = -1
+ logical :: l = .FALSE.
+ end type
+
+ integer :: x[*] = 10
+ class(t), allocatable :: c[:]
+
+ associate (y => x)
+ y = -1
+ y[1] = 35
+ end associate
+ allocate(c[*])
+ associate (f => c)
+ f%b = 17
+ f[1]%l = .TRUE.
+ end associate
+
+ if (x /= 35) stop 1
+
+ if (c%b /= 17) stop 2
+ if (.NOT. c%l) stop 3
+end
+
--
2.46.0