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 <pa...@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 <pa...@gcc.gnu.org> PR fortran/84546 * gfortran.dg/unlimited_polymorphic_29.f90 : New test.
Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 258189) --- gcc/fortran/trans-array.c (working copy) *************** structure_alloc_comps (gfc_symbol * der_ *** 8883,8888 **** --- 8883,8913 ---- 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 Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 258189) --- gcc/fortran/trans-expr.c (working copy) *************** gfc_conv_class_to_class (gfc_se *parmse, *** 1185,1199 **** 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); --- 1185,1216 ---- 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 *** 1295,1308 **** 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); --- 1312,1326 ---- 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); Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 258189) --- gcc/fortran/trans.h (working copy) *************** tree gfc_vptr_deallocate_get (tree); *** 431,437 **** 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); --- 431,437 ---- 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); Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 =================================================================== *** gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 (nonexistent) --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 (working copy) *************** *** 0 **** --- 1,84 ---- + ! { 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.carl...@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