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 <pa...@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 <pa...@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.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 263915)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 10258,10263 ****
--- 10258,10271 ----
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;
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 263915)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3414,3424 ****
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);
--- 3414,3420 ----
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
*** 3659,3669 ****
&& 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
--- 3655,3661 ----
&& 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
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 263916)
--- gcc/fortran/trans-expr.c (working copy)
*************** trans_class_assignment (stmtblock_t *blo
*** 9922,9933 ****
{
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));
--- 9922,9948 ----
{
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
*** 10306,10315 ****
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)
--- 10321,10351 ----
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)
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 263915)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 407,413 ****
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. */
--- 407,418 ----
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. */
Index: gcc/testsuite/gfortran.dg/pr86328.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86328.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86328.f90 (working copy)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Martin <ms...@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
Index: gcc/testsuite/gfortran.dg/pr86328_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86328_12.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86328_12.f90 (working copy)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 comment 12. This had nothing to do with
+ ! the original PR. See below.
+ !
+ ! Contributed by Martin <ms...@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
Index: gcc/testsuite/gfortran.dg/pr86760.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86760.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86760.f90 (working copy)
***************
*** 0 ****
--- 1,57 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86760 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Chris Hansen <han...@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
