https://gcc.gnu.org/g:21e7aa5f3ea44ca2fef8deb8788edffc04901b5c
commit r15-168-g21e7aa5f3ea44ca2fef8deb8788edffc04901b5c
Author: Harald Anlauf <anl...@gmx.de>
Date: Mon Apr 29 19:52:52 2024 +0200
Fortran: fix issues with class(*) assignment [PR114827]
gcc/fortran/ChangeLog:
PR fortran/114827
* trans-array.cc (gfc_alloc_allocatable_for_assignment): Take into
account _len of unlimited polymorphic entities when calculating
the effective element size for allocation size and array span.
Set _len of lhs to _len of rhs.
* trans-expr.cc (trans_class_assignment): Take into account _len
of unlimited polymorphic entities for allocation size.
gcc/testsuite/ChangeLog:
PR fortran/114827
* gfortran.dg/asan/unlimited_polymorphic_34.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 16 +++
gcc/fortran/trans-expr.cc | 13 ++
.../gfortran.dg/asan/unlimited_polymorphic_34.f90 | 135 +++++++++++++++++++++
3 files changed, 164 insertions(+)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..7ec33fb1598 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 0280c441ced..bc8eb419cff 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 00000000000..c69158a1b55
--- /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.carl...@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
