Make allocate with source work, some more offset fixes for implied this_image().

gcc/fortran/ChangeLog:

	* options.c (gfc_post_options): Always set flag_debug_aux_vars for
	shared coarrays.
	* resolve.c (gfc_expr_to_initialize): Set extra dimensions to
	DIMEN_THIS_IMAGE.
	* trans-array.c (cas_add_strides): Re-introduce.
	(cas_add_this_image_offset): Rename add_lbound to
	correct_full_offset, use cas_add_strides.

gcc/testsuite/ChangeLog:

	* gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90: New test.
	* gfortran.dg/caf-shared/cobounds_torture_1.f90: New test.
	* gfortran.dg/caf-shared/cobounds_torture_2.f90: New test.
	* gfortran.dg/caf-shared/cobounds_torture_3.f90: New test.

7 files changed, 202 insertions, 5 deletions

diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index d844fa9..9e32ae6 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -485,6 +485,11 @@ gfc_post_options (const char **pfilename)
     gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
 		     MAX_SUBRECORD_LENGTH);
 
+  /* For now, we always want to debug auxiliary variables we create
+     for shared coarrays.  */
+  if (flag_coarray == GFC_FCOARRAY_SHARED)
+    flag_debug_aux_vars = 1;
+
   gfc_cpp_post_options ();
 
   if (gfc_option.allow_std & GFC_STD_F2008)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e359c20..40a2f6f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7606,17 +7606,34 @@ gfc_expr_to_initialize (gfc_expr *e)
     if (ref->type == REF_ARRAY && ref->next == NULL)
       {
 	if (ref->u.ar.dimen == 0
-	    && ref->u.ar.as && ref->u.ar.as->corank)
+	    && ref->u.ar.as && ref->u.ar.as->corank
+	    && flag_coarray != GFC_FCOARRAY_SHARED)
 	  return result;
 
 	ref->u.ar.type = AR_FULL;
 
 	for (i = 0; i < ref->u.ar.dimen; i++)
-	  ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
-
+	  {
+	    gfc_free_expr (ref->u.ar.start[i]);
+	    gfc_free_expr (ref->u.ar.end[i]);
+	    gfc_free_expr (ref->u.ar.stride[i]);
+	    ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+	  }
 	break;
       }
 
+  if (flag_coarray == GFC_FCOARRAY_SHARED)
+    {
+      for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+	{
+	  gfc_free_expr (ref->u.ar.start[i]);
+	  gfc_free_expr (ref->u.ar.end[i]);
+	  gfc_free_expr (ref->u.ar.stride[i]);
+	  ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+	  ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+	}
+    }
+
   gfc_free_shape (&result->shape, result->rank);
 
   /* Recalculate rank, shape, etc.  */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5fca413..1e3579e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2940,6 +2940,28 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
       gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
 }
 
+/* Add stride from rank beg to end - 1.  */
+
+static tree
+cas_add_strides (tree expr, tree desc, int beg, int end)
+{
+  int i;
+  tree tmp, stride, lbound;
+  tmp = gfc_index_zero_node;
+  for (i = beg; i < end; i++)
+    {
+      stride = gfc_conv_array_stride (desc, i);
+      lbound = gfc_conv_array_lbound (desc, i);
+      tmp =
+	fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(tmp), tmp,
+			 fold_build2_loc (input_location, MULT_EXPR,
+					  TREE_TYPE (stride), stride, lbound));
+    }
+  return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(expr),
+			  expr, tmp);
+}
+
+
 /* If the full offset is needed, this function calculates the new offset via
 
      new_offset = offset
@@ -2947,9 +2969,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	+ sum (stride[i]*lbound[i]) over remaining codim.  */
 
 static tree
-cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_lbound)
+cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar,
+			   bool correct_full_offset)
 {
   tree tmp;
+
   /* Calculate the actual offset.  */
   /* tmp = _gfortran_cas_coarray_this_image (0).  */
   tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_this_image,
@@ -2960,7 +2984,7 @@ cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_l
 			 build_int_cst (TREE_TYPE (tmp), 1));
 
   /* tmp = _gfortran_cas_coarray_this_image (0) - 1 + lbound[first_codim] */
-  if (add_lbound)
+  if (correct_full_offset)
     tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), tmp,
 			   gfc_conv_array_lbound(desc, ar->dimen));
 
@@ -2969,6 +2993,10 @@ cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_l
   tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
 			 gfc_conv_array_stride (desc, ar->dimen), tmp);
 
+  if (correct_full_offset)
+    tmp = cas_add_strides (tmp, desc, ar->as->rank + 1,
+			   ar->as->rank + ar->as->corank);
+
   return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (offset),
 			  offset, tmp);
 }
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90
new file mode 100644
index 0000000..6634653
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+
+program coarray_41
+
+  integer, allocatable :: vec(:)[:,:]
+
+  allocate(vec(10)[2,*], source= 37)
+
+  if (.not. allocated(vec)) error stop
+
+  call foo(vec)
+
+  if (any(vec /= 42)) error stop
+
+  deallocate(vec)
+contains
+
+  subroutine foo(gv)
+
+    integer, allocatable, intent(inout) :: gv(:)[:,:]
+    integer, allocatable :: gvin(:)
+
+    allocate(gvin, mold=gv)
+    gvin = 5
+    gv = gv + gvin
+  end subroutine foo
+
+end program coarray_41
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90
new file mode 100644
index 0000000..2c8b289
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer :: a(2)[77:78,3:*]
+  integer :: b(2)[34:35,2:3,*]
+  integer :: c(2) [-21:-20,2:3,4:5,8:*]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a(:)[ia(1),ia(2)] = me
+  b(:)[ib(1),ib(2),ib(3)] = me + 100
+  c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+!  print '(Z16)',loc(c(1)[ic(1),ic(2),ic(3),ic(4)]) - (this_image() - 1)*8
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90
new file mode 100644
index 0000000..f7fe5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer, allocatable :: a(:)[:,:]
+  integer, allocatable :: b(:)[:,:,:]
+  integer, allocatable :: c(:) [:,:,:,:]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  allocate (a(2)[77:78,3:*])
+  allocate (b(2)[34:35,2:3,*])
+  allocate (c(2) [-21:-20,2:3,4:5,8:*])
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a(:)[ia(1),ia(2)] = me
+  b(:)[ib(1),ib(2),ib(3)] = me + 100
+  c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90
new file mode 100644
index 0000000..4b23795
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer :: a(2)[77:78,3:*]
+  integer :: b(2)[34:35,2:3,*]
+  integer :: c(2) [-21:-20,2:3,4:5,8:*]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a = me
+  b = me + 100
+  c = me + 200
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+