1! { dg-do run } 2! 3! PR fortran/47455 4! 5! Based on an example by Thomas Henlich 6! 7 8module class_t 9 type :: tx 10 integer, dimension(:), allocatable :: i 11 end type tx 12 type :: t 13 type(tx), pointer :: x 14 type(tx) :: y 15 contains 16 procedure :: calc 17 procedure :: find_x 18 procedure :: find_y 19 end type t 20contains 21 subroutine calc(this) 22 class(t), target :: this 23 type(tx), target :: that 24 that%i = [1,2] 25 this%x => this%find_x(that, .true.) 26 if (associated (this%x)) call abort() 27 this%x => this%find_x(that, .false.) 28 if(any (this%x%i /= [5, 7])) call abort() 29 if (.not.associated (this%x,that)) call abort() 30 allocate(this%x) 31 if (associated (this%x,that)) call abort() 32 if (allocated(this%x%i)) call abort() 33 this%x = this%find_x(that, .false.) 34 that%i = [3,4] 35 if(any (this%x%i /= [5, 7])) call abort() ! FAILS 36 37 if (allocated (this%y%i)) call abort() 38 this%y = this%find_y() ! FAILS 39 if (.not.allocated (this%y%i)) call abort() 40 if(any (this%y%i /= [6, 8])) call abort() 41 end subroutine calc 42 function find_x(this, that, l_null) 43 class(t), intent(in) :: this 44 type(tx), target :: that 45 type(tx), pointer :: find_x 46 logical :: l_null 47 if (l_null) then 48 find_x => null() 49 else 50 find_x => that 51 that%i = [5, 7] 52 end if 53 end function find_x 54 function find_y(this) result(res) 55 class(t), intent(in) :: this 56 type(tx), allocatable :: res 57 allocate(res) 58 res%i = [6, 8] 59 end function find_y 60end module class_t 61 62use class_t 63type(t) :: x 64call x%calc() 65end 66