===================================================================
*************** resolve_ordinary_assign (gfc_code *code,
gfc_ref *ref;
symbol_attribute attr;
+ /* Make sure that a vtable exists for intrinsic rhs of an assignment
+ to an unlimited polymorphic lhs. */
+ if (code->expr1
+ && code->expr1->ts.type == BT_CLASS
+ && code->expr1->ts.u.derived
+ && UNLIMITED_POLY (code->expr1))
+ gfc_find_vtab (&code->expr2->ts);
+
if (gfc_extend_assign (code, ns))
{
gfc_expr** rhsptr;
===================================================================
*************** gfc_conv_scalarized_array_ref (gfc_se *
if (is_pointer_array (info->descriptor))
{
if (TREE_CODE (info->descriptor) == COMPONENT_REF)
! {
! decl = gfc_evaluate_now (info->descriptor, &se->pre);
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
! TREE_USED (decl) = 1;
! }
else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
decl = TREE_OPERAND (info->descriptor, 0);
if (is_pointer_array (info->descriptor))
{
if (TREE_CODE (info->descriptor) == COMPONENT_REF)
! decl = info->descriptor;
else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
decl = TREE_OPERAND (info->descriptor, 0);
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
&& is_pointer_array (se->expr))
{
if (TREE_CODE (se->expr) == COMPONENT_REF)
! {
! decl = gfc_evaluate_now (se->expr, &se->pre);
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
! TREE_USED (decl) = 1;
! }
else if (TREE_CODE (se->expr) == INDIRECT_REF)
decl = TREE_OPERAND (se->expr, 0);
else
&& is_pointer_array (se->expr))
{
if (TREE_CODE (se->expr) == COMPONENT_REF)
! decl = se->expr;
else if (TREE_CODE (se->expr) == INDIRECT_REF)
decl = TREE_OPERAND (se->expr, 0);
else
===================================================================
*************** trans_class_assignment (stmtblock_t *blo
{
stmtblock_t alloc;
tree class_han;
- tmp = gfc_vptr_size_get (vptr);
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
gfc_init_block (&alloc);
! gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
{
stmtblock_t alloc;
tree class_han;
+ tree size;
+ tree ctmp;
+
+ size = gfc_vptr_size_get (vptr);
+ if (UNLIMITED_POLY (lhs))
+ {
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_class_len_get (TREE_OPERAND (vptr, 0)));
+ ctmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (TREE_TYPE (tmp)));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, tmp, ctmp, size);
+ }
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
gfc_init_block (&alloc);
! gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
*************** gfc_trans_assignment_1 (gfc_expr * expr1
tmp = NULL_TREE;
if (is_poly_assign)
! tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
! use_vptr_copy || (lhs_attr.allocatable
! && !lhs_attr.dimension),
! flag_realloc_lhs && !lhs_attr.pointer);
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
tmp = NULL_TREE;
if (is_poly_assign)
! {
! if (lhs_attr.allocatable && dealloc && lss == gfc_ss_terminator)
! {
! tree ptr;
!
! ptr = lse.expr;
! if (GFC_CLASS_TYPE_P (TREE_TYPE (ptr)))
! ptr = gfc_class_data_get (ptr);
!
! /* This provides finalization of the lhs before the assignment. */
! tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
! NULL_TREE, true,
! expr1, expr1->ts);
! gfc_add_expr_to_block (&block, tmp);
! tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! void_type_node, ptr,
! build_int_cst (TREE_TYPE (ptr), 0));
! gfc_add_expr_to_block (&block, tmp);
! }
!
! tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
! use_vptr_copy || (lhs_attr.allocatable
! && !lhs_attr.dimension),
! flag_realloc_lhs && !lhs_attr.pointer);
! }
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
===================================================================
*************** gfc_build_array_ref (tree base, tree off
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! span = get_array_span (type, decl);
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! {
! if (TREE_CODE (decl) == COMPONENT_REF)
! span = gfc_conv_descriptor_span_get (decl);
! else
! span = get_array_span (type, decl);
! }
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Martin <mscfd@gmx.net>
+ !
+ program ptr_alloc
+
+ type :: t
+ class(*), allocatable :: val
+ end type
+
+ type :: list
+ type(t), dimension(:), pointer :: ll
+ end type
+
+ integer :: i
+ type(list) :: a
+
+ allocate(a%ll(1:2))
+ do i = 1,2
+ allocate(a%ll(i)%val, source=i)
+ end do
+
+ do i = 1,2
+ call rrr(a, i)
+ end do
+
+ do i = 1,2
+ deallocate(a%ll(i)%val)
+ end do
+ deallocate (a%ll)
+ contains
+
+ subroutine rrr(a, i)
+ type(list), intent(in) :: a
+ class(*), allocatable :: c
+ integer :: i
+
+ allocate(c, source=a%ll(i)%val)
+ select type (c)
+ type is (integer)
+ if (c .ne. i) stop 1
+ end select
+
+ end subroutine
+
+ end
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 comment 12. This had nothing to do with
+ ! the original PR. See below.
+ !
+ ! Contributed by Martin <mscfd@gmx.net>
+ !
+ program classstar_alloc3
+
+ type :: t
+ class(*), allocatable :: val
+ end type
+
+ type :: list
+ type(t), dimension(:), pointer :: ll
+ end type
+
+ integer :: i
+ type(list) :: a
+
+ allocate(a%ll(1:2))
+ do i = 1,2
+ allocate(a%ll(i)%val, source='01')
+ end do
+
+ call rrr(a)
+
+ do i = 1,2
+ deallocate(a%ll(i)%val)
+ end do
+
+ deallocate(a%ll)
+
+ contains
+
+ subroutine rrr(a)
+ type(list), intent(in) :: a
+ class(*), allocatable :: c
+
+ allocate(c, source=a%ll(2)%val)
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 2) stop 1
+ if (c .ne. '01') stop 2
+ end select
+
+ c = a%ll(2)%val ! This caused invalid reads.
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 2) stop 3
+ if (c .ne. '01') stop 4
+ end select
+
+ c = '123456' ! 'c' remained size 2.
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 6) stop 5
+ if (c .ne. '123456') stop 6
+ end select
+ end subroutine
+ end program classstar_alloc3
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86760 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Chris Hansen <hansec@uw.edu>
+ !
+ MODULE test_nesting_mod
+ IMPLICIT NONE
+ TYPE :: test_obj1
+ CONTAINS
+ PROCEDURE :: destroy
+ END TYPE
+
+ TYPE :: obj_ptr
+ CLASS(test_obj1), POINTER :: f => NULL()
+ END TYPE
+
+ TYPE :: obj_container
+ TYPE(obj_ptr), POINTER, DIMENSION(:) :: v => NULL()
+ END TYPE
+
+ integer :: ctr = 0
+
+ CONTAINS
+
+ SUBROUTINE destroy(self)
+ CLASS(test_obj1), INTENT(INOUT):: self
+ ctr = ctr + 1
+ END SUBROUTINE
+
+ SUBROUTINE container_destroy(self)
+ type(obj_container), INTENT(INOUT) :: self
+ INTEGER :: i
+ DO i=1,ubound(self%v,1)
+ CALL self%v(i)%f%destroy()
+ END DO
+ END SUBROUTINE
+
+ END MODULE
+
+
+ PROGRAM test_nesting_ptr
+ USE test_nesting_mod
+ IMPLICIT NONE
+ INTEGER :: i
+ INTEGER, PARAMETER :: n = 2
+ TYPE(obj_container) :: var
+
+ ALLOCATE(var%v(n))
+ DO i=1,n
+ ALLOCATE(test_obj1::var%v(i)%f)
+ END DO
+ CALL container_destroy(var)
+
+ if (ctr .ne. 2) stop 1
+ END
The attached patch fixes PR86328 and PR86760. The regression was caused by my commit r252949. The parts of the patch that fix the PRs are in trans.c and trans-array.c. The problem was caused by fixing the expressions that would provide the 'span' in gfc_build_array_ref, since the latter expected a variable expression. A number of evaluations of component array elements were producing pre blocks that were not added and so the temporaries were not being evaluated. The fix is to pass the COMPONENT_REF and extract the 'span' directly from it. The rest of the patch arises from PR86328 comment #12. In fact, this took most of the time that I have spent on these PRs :-( Having done this, I felt that I had to include this part of the patch in the submission. However, I have found a host of related bugs, which I will put together in one PR. My inclination is to commit the patch without the parts in resolve.c, trans-expr.c and pr86328_12.f90, especially for 8-branch. I am open to suggestions for 9-branch. Bootstraps and regtests on FC28/x68_64 - OK for 8- and 9-branches? Paul 2018-08-29 Paul Thomas <pault@gcc.gnu.org> PR fortran/86328 PR fortran/86760 * resolve.c (resolve_ordinary_assign): Ensure that the vtable is generated for intrinsic assignment to unlimited polymorphic entities. * trans-array.c (gfc_conv_scalarized_array_ref): Do not fix info->descriptor but pass it directly to gfc_build_array_ref. (gfc_conv_array_ref): Likewise for se->expr. * trans-expr.c (trans_class_assignment): For unlimited polymorphic assignments, 'size' must be multiplied by the rhs '_len' values if non-zero. (gfc_trans_assignment_1): For scalar polymorphic assignments to allocatable lhs, finalize and deallocate before the assignment is made. * trans.c (gfc_build_array_ref): If 'decl' is a COMPONENT_REF obtain the span field directly from it. 2018-08-29 Paul Thomas <pault@gcc.gnu.org> PR fortran/86328 PR fortran/86760 * gfortran.dg/pr86328.f90 : New test. * gfortran.dg/pr86328_12.f90 : New test of the problem reported in comment 12 of the PR. * gfortran.dg/pr86760.f90 : New test.