diff mbox

[Fortran] PR 52151: reallocation w/ RESHAPE: also set stride

Message ID 4F32B4DB.20901@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Feb. 8, 2012, 5:46 p.m. UTC 
Hi all,

this patch is a follow up to the recent patch on RESHAPE with an 
allocatable LHS. It turned out that if the LHS is not allocated or has 
the wrong shape, the bounds are not correctly set. Or to be precise: The 
just internally used* "stride" is not set correctly.

Result: Either the wrong elements were accessed or - in particular for 
unallocated arrays with "garbage" or malloc_perturb_ initialization - a 
segfault occurred. Especially the case of having the wrong values is nasty!

The bug was found by Dominique, who found it when looking at the 
chapter08/puppeteer_f2003 example in Damian (et al.)'s book. Thanks 
Dominique!

While that's not a regression, I think the bug is seriously enough and 
the fix simple enough that it should also be applied to 4.6.

Thus: OK for the trunk and 4.6? (The patch has been build and regtested 
on x86-64-linux.)

Tobias

Comments

Steve Kargl Feb. 8, 2012, 6:02 p.m. UTC | #1 
On Wed, Feb 08, 2012 at 06:46:03PM +0100, Tobias Burnus wrote:
> 
> this patch is a follow up to the recent patch on RESHAPE with an 
> allocatable LHS. It turned out that if the LHS is not allocated or has 
> the wrong shape, the bounds are not correctly set. Or to be precise: The 
> just internally used* "stride" is not set correctly.
> 
> Result: Either the wrong elements were accessed or - in particular for 
> unallocated arrays with "garbage" or malloc_perturb_ initialization - a 
> segfault occurred. Especially the case of having the wrong values is nasty!
> 
> The bug was found by Dominique, who found it when looking at the 
> chapter08/puppeteer_f2003 example in Damian (et al.)'s book. Thanks 
> Dominique!
> 
> While that's not a regression, I think the bug is seriously enough and 
> the fix simple enough that it should also be applied to 4.6.
> 
> Thus: OK for the trunk and 4.6? (The patch has been build and regtested 
> on x86-64-linux.)
> 

OK for both trunk and 4.6. Thanks for tracking down the problem.
diff mbox

Patch

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.

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 184010)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -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.  */
-      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);
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/realloc_on_assign_12.f90	(working copy)
@@ -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