1! { dg-do run } 2! 3! Tests corrections to implementation of pointer function assignments. 4! 5! Contributed by Mikael Morin <mikael.morin@sfr.fr> 6! 7module m 8 implicit none 9 type dt 10 integer :: data 11 contains 12 procedure assign_dt 13 generic :: assignment(=) => assign_dt 14 end type 15contains 16 subroutine assign_dt(too, from) 17 class(dt), intent(out) :: too 18 type(dt), intent(in) :: from 19 too%data = from%data + 1 20 end subroutine 21end module m 22 23program p 24 use m 25 integer, parameter :: b = 3 26 integer, target :: a = 2 27 type(dt), target :: tdt 28 type(dt) :: sdt = dt(1) 29 30 func (arg=b) = 1 ! This was rejected as an unclassifiable statement 31 if (a /= 1) STOP 1 32 33 func (b + b - 3) = -1 34 if (a /= -1) STOP 2 35 36 dtfunc () = sdt ! Check that defined assignment is resolved 37 if (tdt%data /= 2) STOP 3 38contains 39 function func(arg) result(r) 40 integer, pointer :: r 41 integer :: arg 42 if (arg == 3) then 43 r => a 44 else 45 r => null() 46 end if 47 end function func 48 function dtfunc() result (r) 49 type(dt), pointer :: r 50 r => tdt 51 end function 52end program p 53