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.

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 88fbba2818a2fbe51ec7400a3e9e07b1bef2a3a5..f9e0d416e487624a0307aa31439bca9c8f4cd50f 100644 (file)
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -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;
     }
 

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index ffc3721efbe1fe1345a80b94184e19ea1740ed44..71312e0e415d4ae94ef26d03e2a3820c2687e655 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -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;
+           }
        }
     }
 

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 9e4fba68550af7d20e97c4b8b369f6268d5e4d2d..c11abb07eb6e89c15c49a676e48c6967e152d973 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -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)
     {
@@ -12713,15 +12766,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);

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 807fa8c6351feb2e19b6098a8847613eeaf17b4f..3b09a139dc0baaa2e36bc2a11e8f0f597f64b456 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -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);

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index fdcce2067563ad9c73c35fb2e1076cfa5b697f25..d67fbe36a24d5407a7538d5215599f335641b98a 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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 *);

diff --git a/gcc/testsuite/gfortran.dg/coarray/associate_1.f90 b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90
new file mode 100644 (file)
index 0000000..ad1473d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/associate_1.f90
@@ -0,0 +1,36 @@
+!{ 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 (this_image() == 1) then
+    if (x /= 35) stop 1
+    if (c%b /= 17) stop 2
+    if (.NOT. c%l) stop 3
+  else
+    if (x /= -1) stop 4
+    if (c%b /= 17) stop 5
+    if (c%l) stop 6
+  end if
+
+end
+