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
2012-02-08 Tobias Burnus <bur...@net-b.de>
PR fortran/52151
* trans-expr.c (fcncall_realloc_result): Set also the stride.
2012-02-08 Tobias Burnus <bur...@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
