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

gcc/fortran/ChangeLog

+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.

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.  */

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);
 

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;

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)

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);

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;
 }

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 *);

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90

+! { 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