gcc/testsuite/gfortran.dg/class_result_8.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 !  Test the fix for the array version of PR80477
   5 !
   6 ! Contributed by Stefano Zaghi  <stefano.zaghi@cnr.it>
   7 !
   8 module a_type_m
   9    implicit none
  10    type :: a_type_t
  11       real :: x
  12       real, allocatable :: y(:)
  13    endtype
  14 contains
  15    subroutine assign_a_type(lhs, rhs)
  16       type(a_type_t), intent(inout) :: lhs
  17       type(a_type_t), intent(in)    :: rhs(:)
  18       lhs%x = rhs(1)%x + rhs(2)%x
  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))
  27       allocate (res(2)%y(1))
  28       res(1)%x = lhs%x
  29       res(2)%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    call assign_a_type (a, add_a_type(a,b))
  38    print *, a%x
  39 end
  40 ! { dg-final { scan-tree-dump-times "builtin_free" 5 "original" } }
  41 ! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } }