Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/class_assign_1.f08 @ 152:2b5abeee2509
update gcc11
author | anatofuz |
---|---|
date | Mon, 25 May 2020 07:50:57 +0900 |
parents | 04ced10e8804 |
children |
line wrap: on
line source
! { 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