1! { dg-do compile } 2! Test fix for PR54286. 3! 4! Contributed by Janus Weil <janus@gcc.gnu.org> 5! Module 'm' added later because original fix missed possibility of 6! null interfaces - thanks to Dominique Dhumieres <dominiq@lps.ens.fr> 7! 8module m 9 type :: foobar 10 real, pointer :: array(:) 11 procedure (), pointer, nopass :: f 12 end type 13contains 14 elemental subroutine fooAssgn (a1, a2) 15 type(foobar), intent(out) :: a1 16 type(foobar), intent(in) :: a2 17 allocate (a1%array(size(a2%array))) 18 a1%array = a2%array 19 a1%f => a2%f 20 end subroutine 21end module m 22 23implicit integer (a) 24type :: t 25 procedure(a), pointer, nopass :: p 26end type 27type(t) :: x 28 29procedure(iabs), pointer :: pp 30procedure(foo), pointer :: pp1 31 32x%p => a ! ok 33if (x%p(0) .ne. loc(foo)) call abort 34if (x%p(1) .ne. loc(iabs)) call abort 35 36x%p => a(1) ! { dg-error "PROCEDURE POINTER mismatch in function result" } 37 38pp => a(1) ! ok 39if (pp(-99) .ne. iabs(-99)) call abort 40 41pp1 => a(2) ! ok 42if (pp1(-99) .ne. -iabs(-99)) call abort 43 44pp => a ! { dg-error "PROCEDURE POINTER mismatch in function result" } 45 46contains 47 48 function a (c) result (b) 49 integer, intent(in) :: c 50 procedure(iabs), pointer :: b 51 if (c .eq. 1) then 52 b => iabs 53 else 54 b => foo 55 end if 56 end function 57 58 integer function foo (arg) 59 integer, intent (in) :: arg 60 foo = -iabs(arg) 61 end function 62end 63