re PR fortran/58085 (Wrong indexing of an array in ASSOCIATE)

2014-04-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/58085
	PR fortran/60717
	* trans.h: Add 'use_offset' bitfield to gfc_se.
	* trans-array.c (gfc_conv_expr_descriptor): Use 'use_offset'
	as a trigger to unconditionally recalculate the offset for
	array slices and constant arrays.
	trans-expr.c (gfc_conv_intrinsic_to_class): Use it.
	trans-stmt.c (trans_associate_var): Ditto.
	(gfc_conv_procedure_call): Ditto.

2014-04-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/60717
	* gfortran.dg/unlimited_polymorphic_17.f90: New test.

	PR fortran/58085
	* gfortran.dg/associate_15.f90: New test.

From-SVN: r209347

gcc/fortran/ChangeLog

@@ -1,3 +1,15 @@
+2014-04-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/58085
+	PR fortran/60717
+	* trans.h: Add 'use_offset' bitfield to gfc_se.
+	* trans-array.c (gfc_conv_expr_descriptor): Use 'use_offset'
+	as a trigger to unconditionally recalculate the offset for
+	array slices and constant arrays.
+	trans-expr.c (gfc_conv_intrinsic_to_class): Use it.
+	trans-stmt.c (trans_associate_var): Ditto.
+	(gfc_conv_procedure_call): Ditto.
+
 2014-04-11  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/58880

gcc/fortran/trans-array.c

@@ -6807,8 +6807,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
       /* Set offset for assignments to pointer only to zero if it is not
          the full array.  */
-      if (se->direct_byref
-	  && info->ref && info->ref->u.ar.type != AR_FULL)
+      if ((se->direct_byref || se->use_offset)
+	  && ((info->ref && info->ref->u.ar.type != AR_FULL)
+	      || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
 	base = gfc_index_zero_node;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
 	base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
@@ -6893,13 +6894,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 				    stride, info->stride[n]);
 
 	  if (se->direct_byref
-	      && info->ref
-	      && info->ref->u.ar.type != AR_FULL)
+	      && ((info->ref && info->ref->u.ar.type != AR_FULL)
+		  || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
 	    {
 	      base = fold_build2_loc (input_location, MINUS_EXPR,
 				      TREE_TYPE (base), base, stride);
 	    }
-	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
 	    {
 	      tmp = gfc_conv_array_lbound (desc, n);
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -6935,8 +6936,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
 				subref_array_target, expr);
 
-      if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-	  && !se->data_not_needed)
+      if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+	   && !se->data_not_needed)
+	  || (se->use_offset && base != NULL_TREE))
 	{
 	  /* Set the offset.  */
 	  gfc_conv_descriptor_offset_set (&loop.pre, parm, base);

gcc/fortran/trans-expr.c

@@ -593,6 +593,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
       else
 	{
 	  parmse->ss = ss;
+	  parmse->use_offset = 1;
 	  gfc_conv_expr_descriptor (parmse, e);
 	  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
 	}
@@ -4378,6 +4379,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			|| CLASS_DATA (fsym)->attr.codimension))
 	    {
 	      /* Pass a class array.  */
+	      parmse.use_offset = 1;
 	      gfc_conv_expr_descriptor (&parmse, e);
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is

gcc/fortran/trans-stmt.c

@@ -1170,16 +1170,18 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       /* If association is to an expression, evaluate it and create temporary.
 	 Otherwise, get descriptor of target for pointer assignment.  */
       gfc_init_se (&se, NULL);
-      if (sym->assoc->variable)
+      if (sym->assoc->variable || e->expr_type == EXPR_ARRAY)
 	{
 	  se.direct_byref = 1;
+	  se.use_offset = 1;
 	  se.expr = desc;
 	}
+
       gfc_conv_expr_descriptor (&se, e);
 
       /* If we didn't already do the pointer assignment, set associate-name
 	 descriptor to the one generated for the temporary.  */
-      if (!sym->assoc->variable)
+      if (!sym->assoc->variable && e->expr_type != EXPR_ARRAY)
 	{
 	  int dim;
 

gcc/fortran/trans.h

@@ -87,6 +87,10 @@ typedef struct gfc_se
      args alias.  */
   unsigned force_tmp:1;
 
+  /* Unconditionally calculate offset for array segments and constant
+     arrays in gfc_conv_expr_descriptor.  */
+  unsigned use_offset:1;
+
   unsigned want_coarray:1;
 
   /* Scalarization parameters.  */
@@ -99,7 +103,7 @@ gfc_se;
 
 /* Denotes different types of coarray.
    Please keep in sync with libgfortran/caf/libcaf.h.  */
-typedef enum 
+typedef enum
 {
   GFC_CAF_COARRAY_STATIC,
   GFC_CAF_COARRAY_ALLOC,
@@ -178,7 +182,7 @@ typedef enum
   /* An intrinsic function call.  Many intrinsic functions which map directly
      to library calls are created as GFC_SS_FUNCTION nodes.  */
   GFC_SS_INTRINSIC,
-  
+
   /* A component of a derived type.  */
   GFC_SS_COMPONENT
 }

gcc/testsuite/ChangeLog

@@ -1,3 +1,11 @@
+2014-04-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/60717
+	* gfortran.dg/unlimited_polymorphic_17.f90: New test.
+
+	PR fortran/58085
+	* gfortran.dg/associate_15.f90: New test.
+
 2014-04-12  Igor Zamyatin  <igor.zamyatin@intel.com>
 
 	PR middle-end/60467

gcc/testsuite/gfortran.dg/associate_15.f90

@@ -0,0 +1,40 @@
+! { dg-do run }
+! Test the fix for PR58085, where the offset for 'x' was set to zero,
+! rather than -1.
+!
+! Contributed by Vladimir Fuka  <vladimir.fuka@gmail.com>
+!
+module foo
+contains
+  function bar (arg) result (res)
+    integer arg, res(3)
+    res = [arg, arg+1, arg +2]
+  end function
+end module
+  use foo
+  real d(3,3)
+  integer a,b,c
+  character(48) line1, line2
+  associate (x=>shape(d))
+    a = x(1)
+    b = x(2)
+    write (line1, *) a, b
+    write (line2, *) x
+    if (trim (line1) .ne. trim (line2)) call abort
+  end associate
+  associate (x=>[1,2])
+    a = x(1)
+    b = x(2)
+    write (line1, *) a, b
+    write (line2, *) x
+    if (trim (line1) .ne. trim (line2)) call abort
+  end associate
+  associate (x=>bar(5)) ! make sure that we haven't broken function association
+    a = x(1)
+    b = x(2)
+    c = x(3)
+    write (line1, *) a, b, c
+    write (line2, *) x
+    if (trim (line1) .ne. trim (line2)) call abort
+  end associate
+end

gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90

@@ -0,0 +1,51 @@
+! { dg-do run }
+! Tests fix for PR60717 in which offsets in recursive calls below
+! were not being set correctly.
+!
+! Reported on comp.lang.fortran by Thomas Schnurrenberger
+!
+module m
+  implicit none
+  real :: chksum0 = 0, chksum1 = 0, chksum2 = 0
+contains
+  recursive subroutine show_real(a)
+    real, intent(in) :: a(:)
+    if (size (a) > 0) then
+      chksum0 = a(1) + chksum0
+      call show_real (a(2:))
+    end if
+    return
+  end subroutine show_real
+  recursive subroutine show_generic1(a)
+    class(*), intent(in) :: a(:)
+    if (size (a) > 0) then
+      select type (a)
+      type is (real)
+        chksum1 = a(1) + chksum1
+      end select
+      call show_generic1 (a(2:)) ! recursive call outside SELECT TYPE
+    end if
+    return
+  end subroutine show_generic1
+  recursive subroutine show_generic2(a)
+    class(*), intent(in) :: a(:)
+    if (size (a) > 0) then
+      select type (a)
+      type is (real)
+        chksum2 = a(1) + chksum2
+        call show_generic2 (a(2:)) ! recursive call inside SELECT TYPE
+      end select
+    end if
+    return
+  end subroutine show_generic2
+end module m
+program test
+  use :: m
+  implicit none
+  real :: array(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
+  call show_real (array)
+  call show_generic1 (array)
+  call show_generic2 (array)
+  if (chksum0 .ne. chksum1) call abort
+  if (chksum0 .ne. chksum2) call abort
+end program test