re PR fortran/52151 (Segfault with realloc on assignment and RESHAPE to unallocated LHS)

2012-02-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52151
        * trans-expr.c (fcncall_realloc_result): Set also the stride.

2012-02-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52151
        * gfortran.dg/realloc_on_assign_12.f90: New.

From-SVN: r184016

gcc/fortran/ChangeLog

@@ -1,3 +1,8 @@
+2012-02-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52151
+	* trans-expr.c (fcncall_realloc_result): Set also the stride.
+
 2012-02-07  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51514

gcc/fortran/trans-expr.c

@@ -6370,16 +6370,15 @@ fcncall_realloc_result (gfc_se *se, int rank)
       gfc_conv_descriptor_ubound_set (&se->post, desc,
 				      gfc_rank_cst[n], tmp);
 
-      /* Accumulate the offset.  */
+      /* Set stride and accumulate the offset.  */
-      tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]);
+      tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
+      gfc_conv_descriptor_stride_set (&se->post, desc,
+				      gfc_rank_cst[n], tmp);
       tmp = fold_build2_loc (input_location, MULT_EXPR,
-				gfc_array_index_type,
+			     gfc_array_index_type, lbound, tmp);
-				lbound, tmp);
       offset = fold_build2_loc (input_location, MINUS_EXPR,
-				gfc_array_index_type,
+				gfc_array_index_type, offset, tmp);
-				offset, tmp);
       offset = gfc_evaluate_now (offset, &se->post);
-
     }
 
   gfc_conv_descriptor_offset_set (&se->post, desc, offset);

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2012-02-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/52151
+	* gfortran.dg/realloc_on_assign_12.f90: New.
+
 2012-02-08  Richard Guenther  <rguenther@suse.de>
 
 	PR rtl-optimization/52170

gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90

@@ -0,0 +1,96 @@
+! { dg-do run }
+!
+! PR fortran/52151
+!
+! Check that the bounds/shape/strides are correctly set
+! for (re)alloc on assignment, if the LHS is either not
+! allocated or has the wrong shape. This test is for
+! code which is only invoked for libgfortran intrinsic
+! such as RESHAPE.
+!
+! Based on the example of PR 52117 by Steven Hirshman
+!
+    PROGRAM RESHAPEIT
+      call unalloc ()
+      call wrong_shape ()
+    contains
+    subroutine unalloc ()
+      INTEGER, PARAMETER :: n1=2, n2=2, n3=2
+      INTEGER            :: m1, m2, m3, lc
+      REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
+      REAL               :: val
+
+      ALLOCATE (A(n1,n2*n3))
+! << B is not allocated
+
+      val = 0
+      lc = 0
+      DO m3=1,n3
+         DO m2=1,n2
+            lc = lc+1
+            DO m1=1,n1
+               val = val+1
+               A(m1, lc) = val
+            END DO
+         END DO
+      END DO
+
+      B = RESHAPE(A, [n1,n2,n3])
+
+      if (any (shape (B)  /= [n1,n2,n3])) call abort ()
+      if (any (ubound (B) /= [n1,n2,n3])) call abort ()
+      if (any (lbound (B) /= [1,1,1])) call abort ()
+
+      lc = 0
+      DO m3=1,n3
+         DO m2=1,n2
+            lc = lc+1
+            DO m1=1,n1
+!               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
+               if (A(m1,lc) /= B(m1,m2,m3)) call abort ()
+            END DO
+         END DO
+      END DO
+      DEALLOCATE(A, B)
+    end subroutine unalloc
+
+    subroutine wrong_shape ()
+      INTEGER, PARAMETER :: n1=2, n2=2, n3=2
+      INTEGER            :: m1, m2, m3, lc
+      REAL, ALLOCATABLE  :: A(:,:), B(:,:,:)
+      REAL               :: val
+
+      ALLOCATE (A(n1,n2*n3))
+      ALLOCATE (B(1,1,1))     ! << shape differs from RHS
+
+      val = 0
+      lc = 0
+      DO m3=1,n3
+         DO m2=1,n2
+            lc = lc+1
+            DO m1=1,n1
+               val = val+1
+               A(m1, lc) = val
+            END DO
+         END DO
+      END DO
+
+      B = RESHAPE(A, [n1,n2,n3])
+
+      if (any (shape (B)  /= [n1,n2,n3])) call abort ()
+      if (any (ubound (B) /= [n1,n2,n3])) call abort ()
+      if (any (lbound (B) /= [1,1,1])) call abort ()
+
+      lc = 0
+      DO m3=1,n3
+         DO m2=1,n2
+            lc = lc+1
+            DO m1=1,n1
+!               PRINT *,'A(',m1,',',lc,') = ',A(m1,lc),' B = ',B(m1,m2,m3)
+               if (A(m1,lc) /= B(m1,m2,m3)) call abort ()
+            END DO
+         END DO
+      END DO
+      DEALLOCATE(A, B)
+    end subroutine wrong_shape
+    END PROGRAM RESHAPEIT