re PR fortran/64578 ([OOP] Seg-fault and ICE with unlimited polymorphic array pointer...

2015-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* trans-expr.c (gfc_trans_subcomponent_assign): Use a deep copy
	for allocatable components, where the source is a variable.

2015-01-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* gfortran.dg/block_13.f08: New test

From-SVN: r219818

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e91159a8d01520812c3497df7c87441cb26de65e..3f308f79fc1b5e8436798e794c752a20b02675b1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/64578
+       * trans-expr.c (gfc_trans_subcomponent_assign): Use a deep copy
+       for allocatable components, where the source is a variable.
+
 2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/55901

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 79eed1e2489b3b85e19edde9d893aacd304938ea..fca6d33011906590fd5005849ed321621f86e199 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6474,8 +6474,16 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
          gfc_init_se (&se, NULL);
          gfc_conv_expr (&se, expr);
          gfc_add_block_to_block (&block, &se.pre);
-         gfc_add_modify (&block, dest,
-                              fold_convert (TREE_TYPE (dest), se.expr));
+         if (cm->ts.u.derived->attr.alloc_comp
+             && expr->expr_type == EXPR_VARIABLE)
+           {
+             tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
+                                        dest, expr->rank);
+             gfc_add_expr_to_block (&block, tmp);
+           }
+         else
+           gfc_add_modify (&block, dest,
+                           fold_convert (TREE_TYPE (dest), se.expr));
          gfc_add_block_to_block (&block, &se.post);
        }
       else

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 34e40ff8d4211398913ecf54aeafa6b6ecb20fb6..8871283b6803b02a136de22586d0fb1748eba659 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/64578
+       * gfortran.dg/block_13.f08: New test
+
 2015-01-18  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/55901

diff --git a/gcc/testsuite/gfortran.dg/block_13.f08 b/gcc/testsuite/gfortran.dg/block_13.f08
new file mode 100644 (file)
index 0000000..5956a90
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/block_13.f08
@@ -0,0 +1,58 @@
+! { dg-do run }
+! Checks the fix for PR57959. The first assignment to a was proceeding
+! without a deep copy. Since the anum field of 'uKnot' was being pointed
+! to twice, the frees in the finally block, following the BLOCK caused
+! a double free.
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+program main
+  implicit none
+  type :: type1
+    real, allocatable :: anum
+    character(len = :), allocatable :: chr
+  end type type1
+  real, parameter :: five = 5.0
+  real, parameter :: point_one = 0.1
+
+  type :: type2
+    type(type1) :: temp
+  end type type2
+  block
+    type(type1) :: uKnot
+    type(type2) :: a
+
+    uKnot = type1 (five, "hello")
+    call check (uKnot%anum, five)
+    call check_chr (uKnot%chr, "hello")
+
+    a = type2 (uKnot) ! Deep copy needed here
+    call check (a%temp%anum, five)
+    call check_chr (a%temp%chr, "hello")
+
+    a = type2 (type1(point_one, "goodbye")) ! Not here
+    call check (a%temp%anum, point_one)
+    call check_chr (a%temp%chr, "goodbye")
+
+    a = type2 (foo (five)) ! Not here
+    call check (a%temp%anum, five)
+    call check_chr (a%temp%chr, "foo set me")
+  end block
+contains
+  subroutine check (arg1, arg2)
+    real :: arg1, arg2
+    if (arg1 .ne. arg2) call abort ()
+  end subroutine
+
+  subroutine check_chr (arg1, arg2)
+    character(*) :: arg1, arg2
+    if (len (arg1) .ne. len (arg2)) call abort
+    if (arg1 .ne. arg2) call abort
+  end subroutine
+
+  type(type1) function foo (arg)
+    real :: arg
+    foo = type1 (arg, "foo set me")
+  end function
+end
+