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 --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346d1806debd509d2f3742b5691bacf9..7ec33fb15986007727b416caeb9946c4e48cdc5b 100644 (file)
--- 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 0280c441ced32bd12362834433e0c0183e5abc9c..bc8eb419cffe02a69caeb02ec5d01e62a843a30a 100644 (file)
--- 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 (file)
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