Dear all,
the attached patch fixes issues with assignments of unlimited polymorphic
entities that were found with the help of valgrind or asan, see PR. Looking
further into it, it turns out that allocation sizes as well as array spans
could be set incorrectly, leading to wrong results or heap corruption.
The fix is rather straightforward: take into the _len of unlimited
polymorphic entities when it is non-zero to get the correct allocation
sizes and array spans.
The patch has been tested by the reporter, see PR.
Regtested on x86_64-pc-linux-gnu. OK for 15-mainline?
I would like to backport this to active branches where appropriate,
starting with 14 after it reopens after release. Is this OK?
Thanks,
Harald
From 3b73471b570898e5a5085422da48d5bf118edff1 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Mon, 29 Apr 2024 19:52:52 +0200
Subject: [PATCH] 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.
---
gcc/fortran/trans-array.cc | 16 +++
gcc/fortran/trans-expr.cc | 12 ++
.../asan/unlimited_polymorphic_34.f90 | 135 ++++++++++++++++++
3 files changed, 163 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
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..4ba40bfdbd3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11991,6 +11991,18 @@ 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. */
+ if (UNLIMITED_POLY (rhs))
+ {
+ 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
--
2.35.3
