gcc/testsuite/gfortran.dg/class_assign_1.f08

   1 ! { dg-do run }
   2 !
   3 ! Check that reallocation of the lhs is done with the correct memory size.
   4
   5
   6 module 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
  22 contains
  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
  32 end module base_mod
  33
  34 module 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
  43 contains
  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
  55 end module extend_mod
  56
  57 program 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
  70 end program test_poly_ass
  71