Applied as 'obvious' in revision 219802. 2015-01-17 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/64578 * trans-expr.c (gfc_trans_pointer_assignment): Make sure that before reinitializing rse, to add the rse.pre to block before creating 'ptrtemp'. * trans-intrinsic.c (gfc_conv_associated): Deal with the class data being a descriptor. 2015-01-17 Paul Thomas <pa...@gcc.gnu.org> PR fortran/64578 * gfortran.dg/unlimited_polymorphic_21.f90: New test Cheers Paul -- 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 +