re PR fortran/56008 ([F03] wrong code with lhs-realloc on assignment with derived...

2013-02-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/56008
	PR fortran/47517
	* trans-array.c (gfc_alloc_allocatable_for_assignment): Save
	the lhs descriptor before it is modified for reallocation. Use
	it to deallocate allocatable components in the reallocation
	block.  Nullify allocatable components for newly (re)allocated
	arrays.

2013-02-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/56008
	* gfortran.dg/realloc_on _assign_16.f90 : New test.

	PR fortran/47517
	* gfortran.dg/realloc_on _assign_17.f90 : New test.

From-SVN: r195741

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 50d7538f9c3f4a9f354140b3947dc902c2a83ac4..c22d3d9908f2b0d0f864e6444716f23172ccf439 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2013-02-04  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/56008
+       PR fortran/47517
+       * trans-array.c (gfc_alloc_allocatable_for_assignment): Save
+       the lhs descriptor before it is modified for reallocation. Use
+       it to deallocate allocatable components in the reallocation
+       block.  Nullify allocatable components for newly (re)allocated
+       arrays.
+
 2013-02-04  Mikael Morin  <mikael@gcc.gnu.org>
 
        PR fortran/54195

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3e658c0dd338c864409e6199902c142a5a8a9494..4553ddc5b537390874dd73c1c434fb3c08c0f8c5 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7941,6 +7941,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tree lbound;
   tree ubound;
   tree desc;
+  tree old_desc;
   tree desc2;
   tree offset;
   tree jump_label1;
@@ -8091,6 +8092,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
                          size1, size2);
   neq_size = gfc_evaluate_now (cond, &fblock);
 
+  /* Deallocation of allocatable components will have to occur on
+     reallocation.  Fix the old descriptor now.  */
+  if ((expr1->ts.type == BT_DERIVED)
+       && expr1->ts.u.derived->attr.alloc_comp)
+    old_desc = gfc_evaluate_now (desc, &fblock);
+  else
+    old_desc = NULL_TREE;
 
   /* Now modify the lhs descriptor and the associated scalarizer
      variables. F2003 7.4.1.3: "If variable is or becomes an
@@ -8201,12 +8209,30 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   /* Realloc expression.  Note that the scalarizer uses desc.data
      in the array reference - (*desc.data)[<element>]. */
   gfc_init_block (&realloc_block);
+
+  if ((expr1->ts.type == BT_DERIVED)
+       && expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
+                                      expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
   tmp = build_call_expr_loc (input_location,
                             builtin_decl_explicit (BUILT_IN_REALLOC), 2,
                             fold_convert (pvoid_type_node, array1),
                             size2);
   gfc_conv_descriptor_data_set (&realloc_block,
                                desc, tmp);
+
+  if ((expr1->ts.type == BT_DERIVED)
+       && expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+                                   expr1->rank);
+      gfc_add_expr_to_block (&realloc_block, tmp);
+    }
+
   realloc_expr = gfc_finish_block (&realloc_block);
 
   /* Only reallocate if sizes are different.  */
@@ -8224,6 +8250,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
                                desc, tmp);
   tmp = gfc_conv_descriptor_dtype (desc);
   gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  if ((expr1->ts.type == BT_DERIVED)
+       && expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+                                   expr1->rank);
+      gfc_add_expr_to_block (&alloc_block, tmp);
+    }
   alloc_expr = gfc_finish_block (&alloc_block);
 
   /* Malloc if not allocated; realloc otherwise.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e6bea3f830fbfce59a4e9b3045250cefe1e2b47f..548ccc12e64271ddd6fc54e013803d637a22cafc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2013-02-04  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/56008
+       * gfortran.dg/realloc_on _assign_16.f90 : New test.
+
+       PR fortran/47517
+       * gfortran.dg/realloc_on _assign_17.f90 : New test.
+
 2013-02-04  Alexander Potapenko <glider@google.com>
             Jack Howarth  <howarth@bromo.med.uc.edu>
            Jakub Jelinek  <jakub@redhat.com>

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90
new file mode 100644 (file)
index 0000000..84af667
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+! Test the fix for PR56008
+!
+! Contributed by Stefan Mauerberger  <stefan.mauerberger@gmail.com>
+!
+PROGRAM main
+    !USE MPI
+
+    TYPE :: test_typ
+        REAL, ALLOCATABLE :: a(:)
+    END TYPE
+
+    TYPE(test_typ) :: xx, yy
+    TYPE(test_typ), ALLOCATABLE :: conc(:)
+
+    !CALL MPI_INIT(i)
+
+    xx = test_typ( [1.0,2.0] )
+    yy = test_typ( [4.0,4.9] )
+
+    conc = [ xx, yy ]
+
+    if (any (int (10.0*conc(1)%a) .ne. [10,20])) call abort
+    if (any (int (10.0*conc(2)%a) .ne. [40,49])) call abort
+
+    !CALL MPI_FINALIZE(i)
+
+END PROGRAM main

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90
new file mode 100644 (file)
index 0000000..61b1e91
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! Test the fix for PR47517
+!
+! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+! from a testcase by James Van Buskirk
+module mytypes
+   implicit none
+   type label
+      integer, allocatable :: parts(:)
+   end type label
+   type table
+      type(label), allocatable :: headers(:)
+   end type table
+end module mytypes
+
+program allocate_assign
+   use mytypes
+   implicit none
+   integer, parameter :: ik8 = selected_int_kind(18)
+   type(table) x1(2)
+   type(table) x2(3)
+   type(table), allocatable :: x(:)
+   integer i, j, k
+   integer(ik8) s
+   call foo
+   s = 0
+   do k = 1, 10000
+      x = x1
+      s = s+x(2)%headers(2)%parts(2)
+      x = x2
+      s = s+x(2)%headers(2)%parts(2)
+   end do
+   if (s .ne. 40000) call abort
+contains
+!
+! TODO - these assignments lose 1872 bytes on x86_64/FC17
+! This is PR38319
+!
+   subroutine foo
+       x1 = [table([(label([(j,j=1,3)]),i=1,3)]), &
+             table([(label([(j,j=1,4)]),i=1,4)])]
+
+       x2 = [table([(label([(j,j=1,4)]),i=1,4)]), &
+             table([(label([(j,j=1,5)]),i=1,5)]), &
+             table([(label([(j,j=1,6)]),i=1,6)])]
+   end subroutine
+end program allocate_assign