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

login
register
mail settings
Submitter Tobias Burnus
Date Feb. 8, 2012, 5:46 p.m.
Message ID <4F32B4DB.20901@net-b.de>
Download mbox | patch
Permalink /patch/140189/
State New
Headers show

Comments

Tobias Burnus - Feb. 8, 2012, 5:46 p.m.
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
Steve Kargl - Feb. 8, 2012, 6:02 p.m.
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.

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