Fixing latest regressions.vehre/head_cosmo

2 files changed, 45 insertions, 8 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6d706e25614..afea5eca7d0 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6912,9 +6912,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       tree from;
       tree to;
       tree base;
-      bool onebased = false;
+      bool onebased = false, rank_remap;
 
       ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
+      rank_remap = ss->dimen < ndim;
 
       if (se->want_coarray)
 	{
@@ -6950,7 +6951,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       /* If we have an array section or are assigning make sure that
 	 the lower bound is 1.  References to the full
 	 array should otherwise keep the original bounds.  */
-      if (!info->ref || info->ref->u.ar.type != AR_FULL)
+      if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
 	for (dim = 0; dim < loop.dimen; dim++)
 	  if (!integer_onep (loop.from[dim]))
 	    {
@@ -7116,7 +7117,19 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       /* Force the offset to be -1, when the lower bound of the highest
 	 dimension is one and the symbol is present and is not a
 	 pointer/allocatable or associated.  */
-      if (onebased && se->use_offset
+      if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	   && !se->data_not_needed)
+	  || (se->use_offset && base != NULL_TREE))
+	{
+	  /* Set the offset depending on base.  */
+	  tmp = rank_remap && !se->direct_byref ?
+		fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, base,
+				 offset)
+	      : base;
+	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
+	}
+      else if (onebased && (!rank_remap || se->use_offset)
 	  && expr->symtree
 	  && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
 	       && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
@@ -7131,11 +7144,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
 	  gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
 	}
-      else if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-		&& !se->data_not_needed)
-	       || (se->use_offset && base != NULL_TREE))
-	/* Set the offset depending on base.  */
-	gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
       else
 	{
 	  /* Only the callee knows what the correct offset it, so just set
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08
new file mode 100644
index 00000000000..aa7cb476879
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_9.f08
@@ -0,0 +1,29 @@
+! { dg-do run }
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>,
+!                Andre Vehreschild  <vehre@gcc.gnu.org>
+
+program main
+
+  type T
+     integer, allocatable :: acc(:)
+  end type
+
+  integer :: n, lb, ub
+  integer :: vec(9)
+  type(T) :: o1, o2
+  vec = [(i, i= 1, 9)]
+  n = 42
+  lb = 7
+  ub = lb + 2
+  allocate(o1%acc, source=vec)
+  allocate(o2%acc, source=o1%acc(lb:ub))
+  if (any (o2%acc /= [7, 8, 9])) call abort()
+  block
+    real, dimension(0:n) :: a
+    real, dimension(:), allocatable :: c
+    call random_number(a)
+    allocate(c,source=a(:))
+    if (any (abs(a - c) > 1E-6)) call abort()
+  end block
+end program main