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