This is a somewhat delayed patch to fix issues with the original
patch, as flagged up by Rainer in comment #12, Rainer in comment #14
and Eric in comment #15. The fix for these problems was posted in
April in comment #17. It was thoroughly tested but remained
uncommitted because my attention was elsewhere.
I have added the fix to Damian's failing test posted at
https://gcc.gnu.org/ml/fortran/2019-11/msg00061.html ? and referenced
by Tobias in comment #23.
The submitted testcase leaks memory as in PR38319, which I will return
to as I work my way through my assigned PRs. I have returned to this
latter PR on several occasions and have thus far not managed to find a
fix for the problem, which is primarily due to various issues with
allocatable component derived type constructor.
For the main part, the patch relies on ensuring vtables are available
and forcing all assignments to unlimited polymorphic entities to use
the vtable _copy.
Regtests on FC30/x86_64 - OK to commit?
Paul
2019-11-17 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/83118
* resolve.c (resolve_ordinary_assign): Generate a vtable if
necessary for scalar non-polymorphic rhs's to unlimited lhs's.
* trans-array.c (structure_alloc_comps): Delete trailing white
spaces.
(gfc_alloc_allocatable_for_assignment): Use earlier evaluation
of 'cond_null'. If unlimited poly initialize 'size1' to zero
and jump to 'no_shape_tests'. Force reallocation of unlimited
polymorphic lhs's. For allocation to unlimited polymorphic lhs
from a class rhs, use the vtable size.
* trans-expr.c (gfc_conv_procedure_call): Ensure the vtable is
present for passing a non-class actual to an unlimited formal.
(gfc_trans_assignment_1): Simplify some of the logic with
'realloc_flag'.
(realloc_flag): Set 'vptr_copy' for all array assignments to
unlimited polymorphic lhs.
2019-11-17 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/83118
* gfortran.dg/unlimited_polymorphic_31.f03: New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 278354)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 10868,10874 ****
/* Make sure there is a vtable and, in particular, a _copy for the
rhs type. */
! if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
--- 10868,10874 ----
/* Make sure there is a vtable and, in particular, a _copy for the
rhs type. */
! if (UNLIMITED_POLY (lhs) && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 278354)
--- gcc/fortran/trans-array.c (working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8822,8828 ****
cdesc = gfc_create_var (cdesc, "cdesc");
DECL_ARTIFICIAL (cdesc) = 1;
!
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
--- 8822,8828 ----
cdesc = gfc_create_var (cdesc, "cdesc");
DECL_ARTIFICIAL (cdesc) = 1;
!
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8833,8839 ****
gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
gfc_index_zero_node, ubound);
!
if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
else
--- 8833,8839 ----
gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
gfc_index_zero_node, ubound);
!
if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
else
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10184,10198 ****
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
- tmp = build3_v (COND_EXPR, cond_null,
- build1_v (GOTO_EXPR, jump_label1),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&fblock, tmp);
-
/* Get arrayspec if expr is a full array. */
if (expr2 && expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym
--- 10184,10194 ----
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
/* Get arrayspec if expr is a full array. */
if (expr2 && expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10207,10212 ****
--- 10203,10220 ----
else
as = NULL;
+ if (UNLIMITED_POLY (expr1))
+ {
+ size1 = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify (&fblock, size1, gfc_index_zero_node);
+ goto no_shape_tests;
+ }
+
+ tmp = build3_v (COND_EXPR, cond_null,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+
/* If the lhs shape is not the same as the rhs jump to setting the
bounds and doing the reallocation....... */
for (n = 0; n < expr1->rank; n++)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10253,10258 ****
--- 10261,10268 ----
gfc_finish_block (&realloc_block));
gfc_add_expr_to_block (&fblock, tmp);
+ no_shape_tests:
+
/* Get the rhs size and fix it. */
if (expr2)
desc2 = rss->info->data.array.descriptor;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10277,10285 ****
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
size1, size2);
! /* If the lhs is deferred length, assume that the element size
! changes and force a reallocation. */
! if (expr1->ts.deferred)
neq_size = gfc_evaluate_now (logical_true_node, &fblock);
else
neq_size = gfc_evaluate_now (cond, &fblock);
--- 10287,10295 ----
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
size1, size2);
! /* If the lhs is deferred length or unlimited polymorphic, assume that
! the element size changes and force a reallocation. */
! if (expr1->ts.deferred || UNLIMITED_POLY (expr1))
neq_size = gfc_evaluate_now (logical_true_node, &fblock);
else
neq_size = gfc_evaluate_now (cond, &fblock);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10424,10431 ****
gfc_array_index_type, tmp,
expr1->ts.u.cl->backend_decl);
}
! else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
! tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
else
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
tmp = fold_convert (gfc_array_index_type, tmp);
--- 10434,10444 ----
gfc_array_index_type, tmp,
expr1->ts.u.cl->backend_decl);
}
! else if (UNLIMITED_POLY (expr1))
! if (expr2->ts.type != BT_CLASS)
! tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
! else
! tmp = gfc_class_vtab_size_get (TREE_OPERAND (desc2, 0));
else
tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
tmp = fold_convert (gfc_array_index_type, tmp);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10603,10613 ****
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
! tmp = build_int_cst (TREE_TYPE (array1), 0);
! cond = fold_build2_loc (input_location, EQ_EXPR,
! logical_type_node,
! array1, tmp);
! tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
--- 10616,10622 ----
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
! tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 278354)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5586,5593 ****
--- 5586,5595 ----
{
/* The intrinsic type needs to be converted to a temporary
CLASS object for the unlimited polymorphic formal. */
+ gfc_find_vtab (&e->ts);
gfc_init_se (&parmse, se);
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+
}
else if (se->ss && se->ss->info->useflags)
{
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10717,10722 ****
--- 10719,10725 ----
bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
+ bool realloc_flag;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10757,10762 ****
--- 10760,10769 ----
|| gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2));
+ realloc_flag = flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2);
/* Only analyze the expressions for coarray properties, when in coarray-lib
mode. */
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 11001,11008 ****
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)
--- 11008,11016 ----
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
! && !lhs_attr.dimension),
! !realloc_flag && 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_trans_assignment_1 (gfc_expr * expr1
*** 11107,11116 ****
}
/* F2003: Allocate or reallocate lhs of allocatable array. */
! if (flag_realloc_lhs
! && gfc_is_reallocatable_lhs (expr1)
! && expr2->rank
! && !is_runtime_conformable (expr1, expr2))
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
--- 11115,11121 ----
}
/* F2003: Allocate or reallocate lhs of allocatable array. */
! if (realloc_flag)
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 11219,11226 ****
return tmp;
}
! if (UNLIMITED_POLY (expr1) && expr1->rank
! && expr2->ts.type != BT_CLASS)
use_vptr_copy = true;
/* Fallback to the scalarizer to generate explicit loops. */
--- 11224,11230 ----
return tmp;
}
! if (UNLIMITED_POLY (expr1) && expr1->rank)
use_vptr_copy = true;
/* Fallback to the scalarizer to generate explicit loops. */
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03 (working copy)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ !
+ ! Test the fix of the test case referenced in comment 17 of PR83118.
+ !
+ ! Contributed by Damian Rouson <dam...@sourceryinstitute.org>
+ !
+ implicit none
+ type Wrapper
+ class(*), allocatable :: elements(:)
+ end type
+ type Mytype
+ real(4) :: r = 42.0
+ end type
+
+ call driver
+ contains
+ subroutine driver
+ class(*), allocatable :: obj
+ type(Wrapper) w
+ integer(4) :: expected4(2) = [42_4, 43_4]
+ integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
+
+ w = new_wrapper (expected4)
+ obj = w
+ call test (obj, 0)
+ obj = new_wrapper (expected8) ! Used to generate a linker error
+ call test (obj, 10)
+ obj = new_wrapper ([mytype (99.0)])
+ call test (obj, 100)
+ obj = Mytype (42.0) ! Used to generate a linker error
+ call test (obj, 1000)
+ end subroutine
+ function new_wrapper(array) result (res)
+ class(*) :: array(:)
+ type(Wrapper) :: res
+ res%elements = array ! Used to runtime segfault
+ end function
+ subroutine test (arg, idx)
+ class(*) :: arg
+ integer :: idx
+ select type (arg)
+ type is (wrapper)
+ select type (z => arg%elements)
+ type is (integer(4))
+ if (any (z .ne. [42_4, 43_4])) stop 1 + idx
+ type is (integer(8))
+ if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
+ type is (Mytype)
+ if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
+ class default
+ stop 2 + idx
+ end select
+ type is (Mytype)
+ if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
+ class default
+ stop 3 + idx
+ end select
+ end subroutine
+ end
