gcc/testsuite/gfortran.dg/class_assign_1.f08

! { dg-do run }
!
! Check that reallocation of the lhs is done with the correct memory size.


module base_mod

  type, abstract :: base
  contains
    procedure(base_add), deferred :: add
    generic :: operator(+) => add
  end type base

  abstract interface
    module function base_add(l, r) result(res)
      class(base), intent(in) :: l
      integer, intent(in) :: r
      class(base), allocatable :: res
    end function base_add
  end interface

contains

  subroutine foo(x)
    class(base), intent(inout), allocatable :: x
    class(base), allocatable :: t

    t = x + 2
    x = t + 40
  end subroutine foo

end module base_mod

module extend_mod
  use base_mod

  type, extends(base) :: extend
    integer :: i
  contains
    procedure :: add
  end type extend

contains
  module function add(l, r) result(res)
    class(extend), intent(in) :: l
    integer, intent(in) :: r
    class(base), allocatable :: res
    select type (l)
      class is (extend)
        res = extend(l%i + r)
      class default
        error stop "Unkown class to add to."
    end select
  end function
end module extend_mod

program test_poly_ass
  use extend_mod
  use base_mod

  class(base), allocatable :: obj
  obj = extend(0)
  call foo(obj)
  select type (obj)
    class is (extend)
      if (obj%i /= 42) error stop
    class default
      error stop "Result's type wrong."
  end select
end program test_poly_ass