1! { dg-do run } 2! 3! Check that reallocation of the lhs is done with the correct memory size. 4 5 6module base_mod 7 8 type, abstract :: base 9 contains 10 procedure(base_add), deferred :: add 11 generic :: operator(+) => add 12 end type base 13 14 abstract interface 15 module function base_add(l, r) result(res) 16 class(base), intent(in) :: l 17 integer, intent(in) :: r 18 class(base), allocatable :: res 19 end function base_add 20 end interface 21 22contains 23 24 subroutine foo(x) 25 class(base), intent(inout), allocatable :: x 26 class(base), allocatable :: t 27 28 t = x + 2 29 x = t + 40 30 end subroutine foo 31 32end module base_mod 33 34module extend_mod 35 use base_mod 36 37 type, extends(base) :: extend 38 integer :: i 39 contains 40 procedure :: add 41 end type extend 42 43contains 44 module function add(l, r) result(res) 45 class(extend), intent(in) :: l 46 integer, intent(in) :: r 47 class(base), allocatable :: res 48 select type (l) 49 class is (extend) 50 res = extend(l%i + r) 51 class default 52 error stop "Unkown class to add to." 53 end select 54 end function 55end module extend_mod 56 57program test_poly_ass 58 use extend_mod 59 use base_mod 60 61 class(base), allocatable :: obj 62 obj = extend(0) 63 call foo(obj) 64 select type (obj) 65 class is (extend) 66 if (obj%i /= 42) error stop 67 class default 68 error stop "Result's type wrong." 69 end select 70end program test_poly_ass 71 72