From 26219cee84430d38c60637b6fcfffcee80e11c14 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 11 Mar 2018 22:25:11 +0000 Subject: [PATCH] re PR fortran/84546 (Bad sourced allocation of CLASS(*) with source with CLASS(*) component) 2018-03-11 Paul Thomas 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 PR fortran/84546 * gfortran.dg/unlimited_polymorphic_29.f90 : New test. From-SVN: r258438 --- gcc/fortran/ChangeLog | 12 ++- gcc/fortran/trans-array.c | 25 ++++++ gcc/fortran/trans-expr.c | 38 ++++++--- gcc/fortran/trans.h | 2 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/unlimited_polymorphic_29.f90 | 84 +++++++++++++++++++ 6 files changed, 154 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 45def3230da..e767908ed02 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2018-03-11 Paul Thomas + + 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 Steven G. Kargl @@ -86,7 +96,7 @@ PR fortran/66128 * simplify.c (is_size_zero_array): New function to check for size zero array. - (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, + (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count, gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity, gfc_simplify_minval, gfc_simplify_maxval, gfc_simplify_norm2, gfc_simplify_product, gfc_simplify_sum): Use it, and implement diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 171cebdfd68..bd731689031 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8883,6 +8883,31 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, 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 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c84cd107370..54bda1d019b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1185,15 +1185,32 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, of the referenced element. */ tree -gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp) +gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp, + bool unlimited) { - 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; + 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); @@ -1295,14 +1312,15 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) if (is_from_desc) { - from_ref = gfc_get_class_array_ref (index, from, from_data); + 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); + to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited); else { tmp = gfc_conv_array_data (to); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 2ada8057735..1bd8206bc45 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -431,7 +431,7 @@ 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_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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c089a1dc273..883fbb0c6a0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-03-11 Paul Thomas + + PR fortran/84546 + * gfortran.dg/unlimited_polymorphic_29.f90 : New test. + 2018-03-11 Steven G. Kargl PR fortran/83939 diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 new file mode 100644 index 00000000000..d4ad39cda1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 @@ -0,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 +! +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 -- 2.30.2