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