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
61
62
63
64
65
|
! { dg-do run }
!
! PR fortran/47455
!
! Based on an example by Thomas Henlich
!
module class_t
type :: tx
integer, dimension(:), allocatable :: i
end type tx
type :: t
type(tx), pointer :: x
type(tx) :: y
contains
procedure :: calc
procedure :: find_x
procedure :: find_y
end type t
contains
subroutine calc(this)
class(t), target :: this
type(tx), target :: that
that%i = [1,2]
this%x => this%find_x(that, .true.)
if (associated (this%x)) call abort()
this%x => this%find_x(that, .false.)
if(any (this%x%i /= [5, 7])) call abort()
if (.not.associated (this%x,that)) call abort()
allocate(this%x)
if (associated (this%x,that)) call abort()
if (allocated(this%x%i)) call abort()
this%x = this%find_x(that, .false.)
that%i = [3,4]
if(any (this%x%i /= [5, 7])) call abort() ! FAILS
if (allocated (this%y%i)) call abort()
this%y = this%find_y() ! FAILS
if (.not.allocated (this%y%i)) call abort()
if(any (this%y%i /= [6, 8])) call abort()
end subroutine calc
function find_x(this, that, l_null)
class(t), intent(in) :: this
type(tx), target :: that
type(tx), pointer :: find_x
logical :: l_null
if (l_null) then
find_x => null()
else
find_x => that
that%i = [5, 7]
end if
end function find_x
function find_y(this) result(res)
class(t), intent(in) :: this
type(tx), allocatable :: res
allocate(res)
res%i = [6, 8]
end function find_y
end module class_t
use class_t
type(t) :: x
call x%calc()
end
|
