resolve.c (resolve_assoc_var): Fix corank setting.

2014-07-04  Tobias Burnus  <burnus@net-b.de>

        * resolve.c (resolve_assoc_var): Fix corank setting.
        * trans-array.c (gfc_conv_descriptor_token): Change assert.
        for select-type temporaries.
        * trans-decl.c (generate_coarray_sym_init): Skip for
        attr.select_type_temporary.
        * trans-expr.c (gfc_conv_procedure_call): Fix for
        select-type temporaries.
        * trans-intrinsic.c (get_caf_token_offset): Ditto.
        (gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set
        the correct dtype.
        * trans-types.h (gfc_get_dtype_rank_type): New.
        * trans-types.c (gfc_get_dtype_rank_type): Ditto.

2014-07-04  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray/coindexed_3.f90: New.

From-SVN: r212299

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 68e903cf0476e5e9148857bc4003b04458430d49..b3764b8ea17782f09c061c731445a02b4a89fb4e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2014-07-04  Tobias Burnus  <burnus@net-b.de>
+
+       * resolve.c (resolve_assoc_var): Fix corank setting.
+       * trans-array.c (gfc_conv_descriptor_token): Change assert.
+       for select-type temporaries.
+       * trans-decl.c (generate_coarray_sym_init): Skip for
+       attr.select_type_temporary. 
+       * trans-expr.c (gfc_conv_procedure_call): Fix for
+       select-type temporaries.
+       * trans-intrinsic.c (get_caf_token_offset): Ditto.
+       (gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set
+       the correct dtype.
+       * trans-types.h (gfc_get_dtype_rank_type): New.
+       * trans-types.c (gfc_get_dtype_rank_type): Ditto.
+
 2014-07-03  Tobias Burnus  <burnus@net-b.de>
        
        * scanner.c (skip_free_comments): Fix indentation.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ca20c294243f10e9e79a806a4a8ecc26772f2b47..15d8dab0efff7cdac4272cd7c4b7511a3626bbb3 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7912,10 +7912,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->as = gfc_get_array_spec ();
       sym->as->rank = target->rank;
       sym->as->type = AS_DEFERRED;
-
-      /* Target must not be coindexed, thus the associate-variable
-        has no corank.  */
-      sym->as->corank = 0;
+      sym->as->corank = gfc_get_corank (target);
     }
 
   /* Mark this as an associate variable.  */

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5558217ab48b88bd1187c9154731e767fce2e6c0..0e018991c0a0801c8313301acb32605bf2d3facb 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -298,7 +298,6 @@ gfc_conv_descriptor_token (tree desc)
 
   type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-  gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
   gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
   field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
 

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cbcd52dc87f9334695dee13dd76d7fae2feb7f7b..93c59b11b669f900efa8a52f92a3baf2899187a0 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4670,7 +4670,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
   tree tmp, size, decl, token;
 
   if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
-      || sym->attr.use_assoc || !sym->attr.referenced)
+      || sym->attr.use_assoc || !sym->attr.referenced
+      || sym->attr.select_type_temporary)
     return;
 
   decl = sym->backend_decl;

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7ee0206e6a0c385d8af1918c04b1f5486c3e9bf4..dba51b081f476d023b71a821f3aa7d7628aa41bf 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4813,7 +4813,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          caf_type = TREE_TYPE (caf_decl);
 
          if (GFC_DESCRIPTOR_TYPE_P (caf_type)
-             && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+             && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
+                 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
            tmp = gfc_conv_descriptor_token (caf_decl);
          else if (DECL_LANG_SPECIFIC (caf_decl)
                   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a1dfdfb2f83694130edc65c33e934cc98f71823c..5aa56838ae7f3c237154de8eed1d865ed486f885 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1179,7 +1179,8 @@ get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
 
   /* Offset between the coarray base address and the address wanted.  */
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
-      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE)
+      && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
+         || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
     *offset = build_int_cst (gfc_array_index_type, 0);
   else if (DECL_LANG_SPECIFIC (caf_decl)
           && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
@@ -1285,7 +1286,10 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
          ar->type = AR_FULL;
        }
       gfc_conv_expr_descriptor (&argse, array_expr);
-
+      /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+         has the wrong type if component references are done.  */
+      gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
+                      gfc_get_dtype_rank_type (array_expr->rank, type));
       if (has_vector)
        {
          vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar);
@@ -1387,7 +1391,12 @@ conv_caf_send (gfc_code *code) {
        }
       lhs_se.want_pointer = 1;
       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
-      lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr)));
+      /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+         has the wrong type if component references are done.  */
+      lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+      tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+      gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+                      gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type));
       if (has_vector)
        {
          vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
@@ -1440,6 +1449,7 @@ conv_caf_send (gfc_code *code) {
          vector bounds separately.  */
       gfc_array_ref *ar, ar2;
       bool has_vector = false;
+      tree tmp2;
 
       if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
        {
@@ -1452,6 +1462,12 @@ conv_caf_send (gfc_code *code) {
        }
       rhs_se.want_pointer = 1;
       gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+      /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+         has the wrong type if component references are done.  */
+      tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
+      tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
+      gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+                      gfc_get_dtype_rank_type (rhs_expr->rank, tmp2));
       if (has_vector)
        {
          rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar);

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bb930f9cdeaaf198aa38a7fbd52c083af578be0c..e55e2d9c1f5e8248644a3a8629a29eacadc18b2f 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1395,23 +1395,13 @@ gfc_get_desc_dim_type (void)
    unknown cases abort.  */
 
 tree
-gfc_get_dtype (tree type)
+gfc_get_dtype_rank_type (int rank, tree etype)
 {
   tree size;
   int n;
   HOST_WIDE_INT i;
   tree tmp;
   tree dtype;
-  tree etype;
-  int rank;
-
-  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
-
-  if (GFC_TYPE_ARRAY_DTYPE (type))
-    return GFC_TYPE_ARRAY_DTYPE (type);
-
-  rank = GFC_TYPE_ARRAY_RANK (type);
-  etype = gfc_get_element_type (type);
 
   switch (TREE_CODE (etype))
     {
@@ -1477,6 +1467,26 @@ gfc_get_dtype (tree type)
   /* TODO: Check this is actually true, particularly when repacking
      assumed size parameters.  */
 
+  return dtype;
+}
+
+
+tree
+gfc_get_dtype (tree type)
+{
+  tree dtype;
+  tree etype;
+  int rank;
+
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
+
+  if (GFC_TYPE_ARRAY_DTYPE (type))
+    return GFC_TYPE_ARRAY_DTYPE (type);
+
+  rank = GFC_TYPE_ARRAY_RANK (type);
+  etype = gfc_get_element_type (type);
+  dtype = gfc_get_dtype_rank_type (rank, etype);
+
   GFC_TYPE_ARRAY_DTYPE (type) = dtype;
   return dtype;
 }

diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 5ed87c0bb5a7ee6404df0abaa6912f753aa8225e..bd3e69c2bab8365c382ac647526ae1a57d9eac7d 100644 (file)
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -97,6 +97,7 @@ int gfc_return_by_reference (gfc_symbol *);
 int gfc_is_nodesc_array (gfc_symbol *);
 
 /* Return the DTYPE for an array.  */
+tree gfc_get_dtype_rank_type (int, tree);
 tree gfc_get_dtype (tree);
 
 tree gfc_get_ppc_type (gfc_component *);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 02e8b93d08f20e3a13580f562640bec53c9f6e12..93f9d35f71a6ea6f5f13268cfc9195149108dee6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2014-07-04  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray/coindexed_3.f90: New.
+
 2014-07-04  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/61654

diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90
new file mode 100644 (file)
index 0000000..46488f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Contributed by Reinhold Bader
+!
+
+program pmup
+  implicit none
+  type t
+    integer :: b, a
+  end type t
+
+  CLASS(*), allocatable :: a(:)[:]
+  integer :: ii
+
+  !! --- ONE --- 
+  allocate(real :: a(3)[*])
+  IF (this_image() == num_images()) THEN
+    SELECT TYPE (a)
+      TYPE IS (real)
+      a(:)[1] = 2.0
+    END SELECT
+  END IF
+  SYNC ALL
+
+  IF (this_image() == 1) THEN
+    SELECT TYPE (a)
+      TYPE IS (real)
+        IF (ALL(A(:)[1] == 2.0)) THEN
+          !WRITE(*,*) 'OK'
+        ELSE
+          WRITE(*,*) 'FAIL'
+          call abort()
+        END IF
+      TYPE IS (t)
+        ii = a(1)[1]%a
+        call abort()
+      CLASS IS (t)
+        ii = a(1)[1]%a
+        call abort()
+    END SELECT
+  END IF
+
+  !! --- TWO --- 
+  deallocate(a)
+  allocate(t :: a(3)[*])
+  IF (this_image() == num_images()) THEN
+    SELECT TYPE (a)
+      TYPE IS (t)
+      a(:)[1]%a = 4.0
+    END SELECT
+  END IF
+  SYNC ALL
+
+  IF (this_image() == 1) THEN
+    SELECT TYPE (a)
+   TYPE IS (real)
+      ii = a(1)[1]
+      call abort()
+    TYPE IS (t)
+      IF (ALL(A(:)[1]%a == 4.0)) THEN
+        !WRITE(*,*) 'OK'
+      ELSE
+        WRITE(*,*) 'FAIL'
+        call abort()
+      END IF
+    CLASS IS (t)
+      ii = a(1)[1]%a
+      call abort()
+    END SELECT
+  END IF
+end program