gcc/testsuite/gfortran.dg/class_result_9.f90

   1 ! { dg-do run }
   2 !
   3 !  Test the fix for an additional bug found while fixing PR80477
   4 !
   5 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   6 !
   7 module a_type_m
   8    implicit none
   9    type :: a_type_t
  10       real :: x
  11       real, allocatable :: y(:)
  12    endtype
  13 contains
  14    subroutine assign_a_type(lhs, rhs)
  15       type(a_type_t), intent(inout) :: lhs
  16       type(a_type_t), intent(in)    :: rhs(:)
  17       lhs%x = rhs(1)%x + rhs(2)%x
  18       lhs%y = rhs(1)%y + rhs(2)%y
  19    end subroutine
  20
  21    function add_a_type(lhs, rhs) result( res )
  22       type(a_type_t), intent(in)  :: lhs
  23       type(a_type_t), intent(in)  :: rhs
  24       class(a_type_t), allocatable :: res(:)
  25       allocate (a_type_t :: res(2))
  26       allocate (res(1)%y(1), source = [10.0])
  27       allocate (res(2)%y(1), source = [20.0])
  28       res(1)%x = lhs%x + rhs%x
  29       res(2)%x = rhs%x + rhs%x
  30    end function
  31 end module
  32
  33 program polymorphic_operators_memory_leaks
  34     use a_type_m
  35     implicit none
  36     type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
  37     class(a_type_t), allocatable :: res(:)
  38
  39     res = add_a_type(a,b)        ! Remarkably, this ICEd - found while debugging the PR.
  40     call assign_a_type (a, res)
  41     if (int (res(1)%x + res(2)%x) .ne. int (a%x)) stop 1
  42     if (int (sum (res(1)%y + res(2)%y)) .ne. int (sum (a%y))) stop 1
  43     deallocate (a%y)
  44     deallocate (res)
  45 end