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 29! We cannot use iabs directly as it is elemental 30abstract interface 31 integer pure function interf_iabs(x) 32 integer, intent(in) :: x 33 end function interf_iabs 34end interface 35 36procedure(interf_iabs), pointer :: pp 37procedure(foo), pointer :: pp1 38 39x%p => a ! ok 40if (x%p(0) .ne. loc(foo)) STOP 1 41if (x%p(1) .ne. loc(iabs)) STOP 2 42 43x%p => a(1) ! { dg-error "PROCEDURE POINTER mismatch in function result" } 44 45pp => a(1) ! ok 46if (pp(-99) .ne. iabs(-99)) STOP 3 47 48pp1 => a(2) ! ok 49if (pp1(-99) .ne. -iabs(-99)) STOP 4 50 51pp => a ! { dg-error "PROCEDURE POINTER mismatch in function result" } 52 53contains 54 55 function a (c) result (b) 56 integer, intent(in) :: c 57 procedure(interf_iabs), pointer :: b 58 if (c .eq. 1) then 59 b => iabs 60 else 61 b => foo 62 end if 63 end function 64 65 pure integer function foo (arg) 66 integer, intent (in) :: arg 67 foo = -iabs(arg) 68 end function 69end 70