From: Tobias Burnus <burnus@net-b.de>
Date: Wed, 8 Feb 2012 21:29:45 +0000 (+0100)
Subject: re PR fortran/52151 (Segfault with realloc on assignment and RESHAPE to unallocated... 
X-Git-Tag: releases/gcc-4.6.3~117
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=c24c8b647ef80126c5c481a510b72342850a12bd;p=thirdparty%2Fgcc.git

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: r184020
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dca2c1334958..8c18aecbe218 100644
--- a/gcc/fortran/ChangeLog
+++ b/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-03  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/52093
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c0c4c6fe9210..3db1244bf25f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5627,16 +5627,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.  */
-      tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]);
+      /* Set stride and accumulate the offset.  */
+      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,
-				lbound, tmp);
+			     gfc_array_index_type, lbound, tmp);
       offset = fold_build2_loc (input_location, MINUS_EXPR,
-				gfc_array_index_type,
-				offset, tmp);
+				gfc_array_index_type, offset, tmp);
       offset = gfc_evaluate_now (offset, &se->post);
-
     }
 
   gfc_conv_descriptor_offset_set (&se->post, desc, offset);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d181cd8d7e49..bbfd905a27b1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/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-07  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc.c-torture/execute/20120207-1.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90
new file mode 100644
index 000000000000..3e0ceb1e3d16
--- /dev/null
+++ b/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