[gcc r14-10191] Fortran: fix issues with class(*) assignment [PR114827]

[gcc r14-10191] Fortran: fix issues with class(*) assignment [PR114827]

[Harald Anlauf]

https://gcc.gnu.org/g:a5046235509caa10a4dc309ca0a8e67892b27750

commit r14-10191-ga5046235509caa10a4dc309ca0a8e67892b27750
Author: Harald Anlauf <anlauf@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.
    
    (cherry picked from commit 21e7aa5f3ea44ca2fef8deb8788edffc04901b5c)

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 30b84762346d..7ec33fb15986 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 0280c441ced3..bc8eb419cffe 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 000000000000..c69158a1b55f
--- /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