[Fortran, Patch, PR81773, PR83606, coarray, v1] Fix coarray get to array with vector indexing

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

attached patch fixes (to my knowledge) the two PRs 81773 and 83606 where the
result of a coarray get() operation is assigned to an array using a vector as
index.  It took me quite long to get it right, because I had to use the
scalarizer which I haven't use directly before. So reviewers with expertise on
using the scalarizer are especially welcome.

Bootstrapped and regtested on x86_64-linux/f27.

Ok for trunk? Backports?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr81773_1.clog
Description: Text document

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index a0bbd584947..3e14ddc25d8 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -2238,8 +2238,9 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
 	    break;
 
 	  /* Exactly matching and forward overlapping ranges don't cause a
-	     dependency.  */
-	  if (fin_dep < GFC_DEP_BACKWARD)
+	     dependency, when they are not part of a coarray ref.  */
+	  if (fin_dep < GFC_DEP_BACKWARD
+	      && lref->u.ar.codimen == 0 && rref->u.ar.codimen == 0)
 	    return 0;
 
 	  /* Keep checking.  We only have a dependency if
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index bd731689031..b68e77d5281 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3215,7 +3215,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
     }
 
   /* Multiply by the stride.  */
-  if (!integer_onep (stride))
+  if (stride != NULL && !integer_onep (stride))
     index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			     index, stride);
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a45aec708fb..00edd447bb2 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1907,34 +1907,124 @@ conv_caf_send (gfc_code *code) {
     }
   else
     {
-      /* If has_vector, pass descriptor for whole array and the
-         vector bounds separately.  */
-      gfc_array_ref *ar, ar2;
-      bool has_vector = false;
+      bool has_vector = gfc_has_vector_subscript (lhs_expr);
 
-      if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr))
+      if (gfc_is_coindexed (lhs_expr) || !has_vector)
 	{
-          has_vector = true;
-          ar = gfc_find_array_ref (lhs_expr);
-	  ar2 = *ar;
-	  memset (ar, '\0', sizeof (*ar));
-	  ar->as = ar2.as;
-	  ar->type = AR_FULL;
+	  /* If has_vector, pass descriptor for whole array and the
+	     vector bounds separately.  */
+	  gfc_array_ref *ar, ar2;
+	  bool has_tmp_lhs_array = false;
+	  if (has_vector)
+	    {
+	      has_tmp_lhs_array = true;
+	      ar = gfc_find_array_ref (lhs_expr);
+	      ar2 = *ar;
+	      memset (ar, '\0', sizeof (*ar));
+	      ar->as = ar2.as;
+	      ar->type = AR_FULL;
+	    }
+	  lhs_se.want_pointer = 1;
+	  gfc_conv_expr_descriptor (&lhs_se, lhs_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 (has_vector ? ar2.dimen
+							      : lhs_expr->rank,
+						   lhs_type));
+	  if (has_tmp_lhs_array)
+	    {
+	      vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
+	      *ar = ar2;
+	    }
 	}
-      lhs_se.want_pointer = 1;
-      gfc_conv_expr_descriptor (&lhs_se, lhs_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 (has_vector ? ar2.dimen
-							  : lhs_expr->rank,
-		      lhs_type));
-      if (has_vector)
+      else
 	{
-	  vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
-	  *ar = ar2;
+	  /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
+	     indexed array expression.  This is rewritten to:
+
+	     tmp_array = arr2[...]
+	     arr1 ([...]) = tmp_array
+
+	     because using the standard gfc_conv_expr (lhs_expr) did the
+	     assignment with lhs and rhs exchanged.  */
+
+	  gfc_ss *lss_for_tmparray, *lss_real;
+	  gfc_loopinfo loop;
+	  gfc_se se;
+	  stmtblock_t body;
+	  tree tmparr_desc, src;
+	  tree index = gfc_index_zero_node;
+	  tree stride = gfc_index_zero_node;
+	  int n;
+
+	  /* Walk both sides of the assignment, once to get the shape of the
+	     temporary array to create right.  */
+	  lss_for_tmparray = gfc_walk_expr (lhs_expr);
+	  /* And a second time to be able to create an assignment of the
+	     temporary to the lhs_expr.  gfc_trans_create_temp_array replaces
+	     the tree in the descriptor with the one for the temporary
+	     array.  */
+	  lss_real = gfc_walk_expr (lhs_expr);
+	  gfc_init_loopinfo (&loop);
+	  gfc_add_ss_to_loop (&loop, lss_for_tmparray);
+	  gfc_add_ss_to_loop (&loop, lss_real);
+	  gfc_conv_ss_startstride (&loop);
+	  gfc_conv_loop_setup (&loop, &lhs_expr->where);
+	  lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+	  gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
+				       lss_for_tmparray, lhs_type, NULL_TREE,
+				       false, true, false,
+				       &lhs_expr->where);
+	  tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
+	  gfc_start_scalarized_body (&loop, &body);
+	  gfc_init_se (&se, NULL);
+	  gfc_copy_loopinfo_to_se (&se, &loop);
+	  se.ss = lss_real;
+	  gfc_conv_expr (&se, lhs_expr);
+	  gfc_add_block_to_block (&body, &se.pre);
+
+	  /* Walk over all indexes of the loop.  */
+	  for (n = loop.dimen - 1; n > 0; --n)
+	    {
+	      tmp = loop.loopvar[n];
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, tmp, loop.from[n]);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp, index);
+
+	      stride = fold_build2_loc (input_location, MINUS_EXPR,
+					gfc_array_index_type,
+					loop.to[n - 1], loop.from[n - 1]);
+	      stride = fold_build2_loc (input_location, PLUS_EXPR,
+					gfc_array_index_type,
+					stride, gfc_index_one_node);
+
+	      index = fold_build2_loc (input_location, MULT_EXPR,
+				       gfc_array_index_type, tmp, stride);
+	    }
+
+	  index = fold_build2_loc (input_location, MINUS_EXPR,
+				   gfc_array_index_type,
+				   index, loop.from[0]);
+
+	  index = fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type,
+				   loop.loopvar[0], index);
+
+	  src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
+	  src = gfc_build_array_ref (src, index, NULL);
+	  /* Now create the assignment of lhs_expr = tmp_array.  */
+	  gfc_add_modify (&body, se.expr, src);
+	  gfc_add_block_to_block (&body, &se.post);
+	  lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
+	  gfc_trans_scalarizing_loops (&loop, &body);
+	  gfc_add_block_to_block (&loop.pre, &loop.post);
+	  gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
+	  gfc_free_ss (lss_for_tmparray);
+	  gfc_free_ss (lss_real);
 	}
     }
 
diff --git a/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90 b/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90
new file mode 100644
index 00000000000..04714711707
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/get_to_indexed_array_1.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+
+! Test that index vector on lhs of caf-expression works correctly.
+
+program pr81773
+
+  integer, parameter :: ndim = 5
+  integer :: i
+  integer :: vec(ndim) = -1
+  integer :: res(ndim)[*] = [ (i, i=1, ndim) ]
+  type T
+    integer :: padding
+    integer :: dest(ndim)
+    integer :: src(ndim)
+  end type
+
+  type(T) :: dest
+  type(T), allocatable :: caf[:]
+
+  vec([ndim, 3, 1]) = res(1:3)[1]
+  if (any (vec /= [ 3, -1, 2, -1, 1])) stop 1
+
+  dest = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] )
+  dest%dest([ 4,3,2 ]) = res(3:5)[1]
+  if (any (dest%dest /= [-1, 5, 4, 3, -1])) stop 2
+
+  vec(:) = -1
+  allocate(caf[*], source = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] ))
+  vec([ 5,3,2 ]) = caf[1]%src(2:4)
+  if (any (vec /= [ -1, 0, 1, -1, 2])) stop 3
+end
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90 b/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90
new file mode 100644
index 00000000000..efb78353637
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/get_to_indirect_array.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Test that pr81773/fortran is fixed.
+
+program get_to_indexed_array
+
+  integer, parameter :: ndim = 5
+  integer :: i
+  integer :: vec(1:ndim) = 0
+  integer :: indx(1:2) = [3, 2]
+  integer :: mat(1:ndim, 1:ndim) = 0
+  integer :: res(1:ndim)[*]=[ (i, i=1, ndim) ]
+
+  ! No sync needed, because this test always is running on single image
+  vec([ndim , 1]) = res(1:2)[1]
+  if (vec(1) /= res(2) .or. vec(ndim) /= res(1)) then
+    print *,"vec: ", vec, " on image: ", this_image()
+    stop 1
+  end if
+
+  mat(2:3,[indx(:)]) = reshape(res(1:4)[1], [2, 2])
+  if (any(mat(2:3, 3:2:-1) /= reshape(res(1:4), [2,2]))) then
+    print *, "mat: ", mat, " on image: ", this_image()
+    stop 2
+  end if
+end
+
+! vim:ts=2:sts=2:sw=2: