1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
! { dg-do run }
! PR48705 - ALLOCATE with class function expression for SOURCE failed.
! This is the original test in the PR.
!
! Reported by Tobias Burnus <burnus@gcc.gnu.org>
!
module generic_deferred
implicit none
type, abstract :: addable
contains
private
procedure(add), deferred :: a
generic, public :: operator(+) => a
end type addable
abstract interface
function add(x, y) result(res)
import :: addable
class(addable), intent(in) :: x, y
class(addable), allocatable :: res
end function add
end interface
type, extends(addable) :: vec
integer :: i(2)
contains
procedure :: a => a_vec
end type
contains
function a_vec(x, y) result(res)
class(vec), intent(in) :: x
class(addable), intent(in) :: y
class(addable), allocatable :: res
integer :: ii(2)
select type(y)
class is (vec)
ii = y%i
end select
allocate(vec :: res)
select type(res)
type is (vec)
res%i = x%i + ii
end select
end function
end module generic_deferred
program prog
use generic_deferred
implicit none
type(vec) :: x, y
class(addable), allocatable :: z
! x = vec( (/1,2/) ); y = vec( (/2,-2/) )
x%i = (/1,2/); y%i = (/2,-2/)
allocate(z, source= x + y)
select type(z)
type is(vec)
if (z%i(1) /= 3 .or. z%i(2) /= 0) then
write(*,*) 'FAIL'
else
write(*,*) 'OK'
end if
end select
end program prog
|
