===================================================================
*************** structure_alloc_comps (gfc_symbol * der_
gfc_init_block (&tmpblock);
+ gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
+ gfc_class_vptr_get (comp));
+
+ /* Copy the unlimited '_len' field. If it is greater than zero
+ (ie. a character(_len)), multiply it by size and use this
+ for the malloc call. */
+ if (UNLIMITED_POLY (c))
+ {
+ tree ctmp;
+ gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
+ gfc_class_len_get (comp));
+
+ size = gfc_evaluate_now (size, &tmpblock);
+ tmp = gfc_class_len_get (comp);
+ ctmp = fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, size,
+ fold_convert (size_type_node, 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,
+ size_type_node, tmp, ctmp, size);
+ size = gfc_evaluate_now (size, &tmpblock);
+ }
+
/* Coarray component have to have the same allocation status and
shape/type-parameter/effective-type on the LHS and RHS of an
intrinsic assignment. Hence, we did not deallocated them - and
===================================================================
*************** gfc_conv_class_to_class (gfc_se *parmse,
of the referenced element. */
tree
! gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
{
! tree data = data_comp != NULL_TREE ? data_comp :
! gfc_class_data_get (class_decl);
! tree size = gfc_class_vtab_size_get (class_decl);
! tree offset = fold_build2_loc (input_location, MULT_EXPR,
! gfc_array_index_type,
! index, size);
! tree ptr;
data = gfc_conv_descriptor_data_get (data);
ptr = fold_convert (pvoid_type_node, data);
ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
of the referenced element. */
tree
! gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
! bool unlimited)
{
! tree data, size, tmp, ctmp, offset, ptr;
!
! data = data_comp != NULL_TREE ? data_comp :
! gfc_class_data_get (class_decl);
! size = gfc_class_vtab_size_get (class_decl);
!
! if (unlimited)
! {
! tmp = fold_convert (gfc_array_index_type,
! gfc_class_len_get (class_decl));
! 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);
! }
!
! offset = fold_build2_loc (input_location, MULT_EXPR,
! gfc_array_index_type,
! index, size);
!
data = gfc_conv_descriptor_data_get (data);
ptr = fold_convert (pvoid_type_node, data);
ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
*************** gfc_copy_class_to_class (tree from, tree
if (is_from_desc)
{
! from_ref = gfc_get_class_array_ref (index, from, from_data);
vec_safe_push (args, from_ref);
}
else
vec_safe_push (args, from_data);
if (is_to_class)
! to_ref = gfc_get_class_array_ref (index, to, to_data);
else
{
tmp = gfc_conv_array_data (to);
if (is_from_desc)
{
! from_ref = gfc_get_class_array_ref (index, from, from_data,
! unlimited);
vec_safe_push (args, from_ref);
}
else
vec_safe_push (args, from_data);
if (is_to_class)
! to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
else
{
tmp = gfc_conv_array_data (to);
===================================================================
*************** tree gfc_vptr_deallocate_get (tree);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
tree gfc_get_vptr_from_expr (tree);
! tree gfc_get_class_array_ref (tree, tree, tree);
tree gfc_copy_class_to_class (tree, tree, tree, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
tree gfc_get_vptr_from_expr (tree);
! tree gfc_get_class_array_ref (tree, tree, tree, bool);
tree gfc_copy_class_to_class (tree, tree, tree, bool);
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
===================================================================
***************
+ ! { dg-do run }
+ !
+ ! Test the fix for PR84546 in which the failing cases would
+ ! have x%vec = ['foo','b '].
+ !
+ ! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
+ !
+ module any_vector_type
+
+ type :: any_vector
+ class(*), allocatable :: vec(:)
+ end type
+
+ interface any_vector
+ procedure any_vector1
+ end interface
+
+ contains
+
+ function any_vector1(vec) result(this)
+ class(*), intent(in) :: vec(:)
+ type(any_vector) :: this
+ allocate(this%vec, source=vec)
+ end function
+
+ end module
+
+ program main
+
+ use any_vector_type
+ implicit none
+
+ class(*), allocatable :: x
+ character(*), parameter :: vec(2) = ['foo','bar']
+ integer :: vec1(3) = [7,8,9]
+
+ call foo1
+ call foo2
+ call foo3
+ call foo4
+
+ contains
+
+ subroutine foo1 ! This always worked
+ allocate (any_vector :: x)
+ select type (x)
+ type is (any_vector)
+ x = any_vector(vec)
+ end select
+ call bar(1)
+ deallocate (x)
+ end
+
+ subroutine foo2 ! Failure found during diagnosis
+ x = any_vector (vec)
+ call bar(2)
+ deallocate (x)
+ end
+
+ subroutine foo3 ! Original failure
+ allocate (x, source = any_vector (vec))
+ call bar(3)
+ deallocate (x)
+ end
+
+ subroutine foo4 ! This always worked
+ allocate (x, source = any_vector (vec1))
+ call bar(4)
+ deallocate (x)
+ end
+
+ subroutine bar (stop_flag)
+ integer :: stop_flag
+ select type (x)
+ type is (any_vector)
+ select type (xvec => x%vec)
+ type is (character(*))
+ if (any(xvec /= vec)) stop stop_flag
+ type is (integer)
+ if (any(xvec /= (vec1))) stop stop_flag
+ end select
+ end select
+ end
+ end program
This regression came about because the vtable deep copy for derived types with unlimited polymorphic components was not making use of the _len parameter to compute the memory to be allocated and the offsets to array elements. The ChangeLogs are reasonably self explanatory. Bootstraps and regtests on FC27/x86_64 - OK for trunk and 7-branch? Paul 2018-03-11 Paul Thomas <pault@gcc.gnu.org> PR fortran/84546 * trans-array.c (structure_alloc_comps): Make sure that the vptr is copied and that the unlimited polymorphic _len is used to compute the size to be allocated. * trans-expr.c (gfc_get_class_array_ref): If unlimited, use the unlimited polymorphic _len for the offset to the element. (gfc_copy_class_to_class): Set the new 'unlimited' argument. * trans.h : Add the boolean 'unlimited' to the prototype. 2018-03-11 Paul Thomas <pault@gcc.gnu.org> PR fortran/84546 * gfortran.dg/unlimited_polymorphic_29.f90 : New test.