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