From 16e247566db1df18a63965f8b3da7345459c6296 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Mon, 4 Feb 2013 22:33:15 +0000
Subject: [PATCH] re PR fortran/56008 ([F03] wrong code with lhs-realloc on
assignment with derived types having allocatable components)
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
---
gcc/fortran/ChangeLog | 10 ++++
gcc/fortran/trans-array.c | 33 +++++++++++++
gcc/testsuite/ChangeLog | 8 ++++
.../gfortran.dg/realloc_on_assign_16.f90 | 28 +++++++++++
.../gfortran.dg/realloc_on_assign_17.f90 | 47 +++++++++++++++++++
5 files changed, 126 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90
create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 50d7538f9c3f..c22d3d9908f2 100644
--- 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 3e658c0dd338..4553ddc5b537 100644
--- 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 e6bea3f830fb..548ccc12e642 100644
--- 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
index 000000000000..84af6670f66d
--- /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
index 000000000000..61b1e91d6419
--- /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
--
GitLab