diff options
| -rw-r--r-- | gcc/fortran/trans-array.cc | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90 | 135 |
3 files changed, 164 insertions, 0 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 30b8476..7ec33fb 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11278,6 +11278,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, linfo->delta[dim], tmp); } + /* Take into account _len of unlimited polymorphic entities, so that span + for array descriptors and allocation sizes are computed correctly. */ + if (UNLIMITED_POLY (expr2)) + { + tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0)); + len = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, len), + size_one_node); + elemsize2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, elemsize2, + fold_convert (gfc_array_index_type, len)); + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); @@ -11324,6 +11337,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), TYPE_SIZE_UNIT (type))); + else if (UNLIMITED_POLY (expr2)) + gfc_add_modify (&fblock, tmp, + gfc_class_len_get (TREE_OPERAND (desc2, 0))); else gfc_add_modify (&fblock, tmp, build_int_cst (TREE_TYPE (tmp), 0)); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 0280c44..bc8eb41 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -11991,6 +11991,19 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, old_vptr = build_int_cst (TREE_TYPE (vptr), 0); size = gfc_vptr_size_get (rhs_vptr); + + /* Take into account _len of unlimited polymorphic entities. + TODO: handle class(*) allocatable function results on rhs. */ + if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE) + { + tree len = trans_get_upoly_len (block, rhs); + len = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, len), + size_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size), + size, fold_convert (TREE_TYPE (size), len)); + } + tmp = lse->expr; class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) ? gfc_class_data_get (tmp) : tmp; diff --git a/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90 b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90 new file mode 100644 index 0000000..c69158a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90 @@ -0,0 +1,135 @@ +! { dg-do run } +! PR fortran/114827 - issues with class(*) assignment found by valgrind +! +! Contributed by Neil Carlson <neil.n.carlson@gmail.com> + +program main + implicit none + call run + call run1 + call run2 +contains + ! Scalar tests + subroutine run () + character(*), parameter :: c = 'fubarfubarfubarfubarfubarfu' + character(*,kind=4), parameter :: d = 4_"abcdef" + complex, parameter :: z = (1.,2.) + class(*), allocatable :: y + + call foo (c, y) + select type (y) + type is (character(*)) +! print *, y(5:6) ! ICE (-> pr114874) + if (y /= c) stop 1 + class default + stop 2 + end select + + call foo (z, y) + select type (y) + type is (complex) + if (y /= z) stop 3 + class default + stop 4 + end select + + call foo (d, y) + select type (y) + type is (character(*,kind=4)) +! print *, y ! NAG fails here + if (y /= d) stop 5 + class default + stop 6 + end select + end subroutine + ! + subroutine foo (a, b) + class(*), intent(in) :: a + class(*), allocatable :: b + b = a + end subroutine + + ! Rank-1 tests + subroutine run1 () + character(*), parameter :: c(*) = ['fubar','snafu'] + character(*,kind=4), parameter :: d(*) = [4_"abc",4_"def"] + real, parameter :: r(*) = [1.,2.,3.] + class(*), allocatable :: y(:) + + call foo1 (c, y) + select type (y) + type is (character(*)) +! print *, ">",y(2)(1:3),"< >", c(2)(1:3), "<" + if (any (y /= c)) stop 11 + if (y(2)(1:3) /= c(2)(1:3)) stop 12 + class default + stop 13 + end select + + call foo1 (r, y) + select type (y) + type is (real) + if (any (y /= r)) stop 14 + class default + stop 15 + end select + + call foo1 (d, y) + select type (y) + type is (character(*,kind=4)) +! print *, ">",y(2)(2:3),"< >", d(2)(2:3), "<" + if (any (y /= d)) stop 16 + class default + stop 17 + end select + end subroutine + ! + subroutine foo1 (a, b) + class(*), intent(in) :: a(:) + class(*), allocatable :: b(:) + b = a + end subroutine + + ! Rank-2 tests + subroutine run2 () + character(7) :: c(2,3) + complex :: z(3,3) + integer :: i, j + class(*), allocatable :: y(:,:) + + c = reshape (['fubar11','snafu21',& + 'fubar12','snafu22',& + 'fubar13','snafu23'],shape(c)) + call foo2 (c, y) + select type (y) + type is (character(*)) +! print *, y(2,1) + if (y(2,1) /= c(2,1)) stop 21 + if (any (y /= c)) stop 22 + class default + stop 23 + end select + + do j = 1, size (z,2) + do i = 1, size (z,1) + z(i,j) = cmplx (i,j) + end do + end do + call foo2 (z, y) + select type (y) + type is (complex) +! print *, y(2,1) + if (any (y%re /= z%re)) stop 24 + if (any (y%im /= z%im)) stop 25 + class default + stop 26 + end select + end subroutine + ! + subroutine foo2 (a, b) + class(*), intent(in) :: a(:,:) + class(*), allocatable :: b(:,:) + b = a + end subroutine + +end program |