Dear All,
Andre's patch for PR60357 did not fix this PR as we had hoped. The fix
needed is trivial, nay 'obvious'.
The problem was that a deep copy was not being performed; just an
assignement of the pointers to the data. In consequence the testcase
was being clobbered with a double free in the 'finally' block
generated by the fortran block.
Note that the PR title shows this as an F03 bug. However, the example
crashed because of the block construct, which is F2008. For this
reason, the testcase is f08.
Boostrapped and regtested on x86_64/FC21 - I will commit to trunk as 'obvious'
Cheers
Paul
2015-01-18 Paul Thomas <pa...@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 <pa...@gcc.gnu.org>
PR fortran/64578
* gfortran.dg/block_13.f08: New test
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 219801)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 7075,7080 ****
--- 7075,7081 ----
rse.expr = gfc_class_data_get (rse.expr);
else
{
+ gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 7146,7151 ****
--- 7147,7153 ----
}
else
{
+ gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 219800)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 6554,6560 ****
--- 6554,6564 ----
arg1se.expr = build_fold_indirect_ref_loc (input_location,
arg1se.expr);
if (arg1->expr->ts.type == BT_CLASS)
+ {
tmp2 = gfc_class_data_get (arg1se.expr);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ }
else
tmp2 = arg1se.expr;
}
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 (working copy)
***************
*** 0 ****
--- 1,35 ----
+ ! { dg-do run }
+ ! Tests the fix for PR64578.
+ !
+ ! Contributed by Damian Rouson <dam...@sourceryinstitute.org>
+ !
+ type foo
+ real, allocatable :: component(:)
+ end type
+ type (foo), target :: f
+ class(*), pointer :: ptr(:)
+ allocate(f%component(1),source=[0.99])
+ call associate_pointer(f,ptr)
+ select type (ptr)
+ type is (real)
+ if (abs (ptr(1) - 0.99) > 1e-5) call abort
+ end select
+ ptr => return_pointer(f) ! runtime segmentation fault
+ if (associated(return_pointer(f)) .neqv. .true.) call abort
+ select type (ptr)
+ type is (real)
+ if (abs (ptr(1) - 0.99) > 1e-5) call abort
+ end select
+ contains
+ subroutine associate_pointer(this, item)
+ class(foo), target :: this
+ class(*), pointer :: item(:)
+ item => this%component
+ end subroutine
+ function return_pointer(this)
+ class(foo), target :: this
+ class(*), pointer :: return_pointer(:)
+ return_pointer => this%component
+ end function
+ end
+
