1! { dg-do run }
2!
3! PR 36704: Procedure pointer as function result
4!
5! Contributed by Janus Weil <janus@gcc.gnu.org>
6
7module mo
8contains
9
10  function j()
11    implicit none
12    procedure(integer),pointer :: j
13    intrinsic iabs
14    j => iabs
15  end function
16
17  subroutine sub(y)
18    integer,intent(inout) :: y
19    y = y**2
20  end subroutine
21
22end module
23
24
25program proc_ptr_14
26use mo
27implicit none
28intrinsic :: iabs
29integer :: x
30procedure(integer),pointer :: p,p2
31procedure(sub),pointer :: ps
32
33p => a()
34if (p(-1)/=1) call abort()
35p => b()
36if (p(-2)/=2) call abort()
37p => c()
38if (p(-3)/=3) call abort()
39
40ps => d()
41x = 4
42call ps(x)
43if (x/=16) call abort()
44
45p => dd()
46if (p(-4)/=4) call abort()
47
48ps => e(sub)
49x = 5
50call ps(x)
51if (x/=25) call abort()
52
53p => ee()
54if (p(-5)/=5) call abort()
55p => f()
56if (p(-6)/=6) call abort()
57p => g()
58if (p(-7)/=7) call abort()
59
60ps => h(sub)
61x = 2
62call ps(x)
63if (x/=4) call abort()
64
65p => i()
66if (p(-8)/=8) call abort()
67p => j()
68if (p(-9)/=9) call abort()
69
70p => k(p2)
71if (p(-10)/=p2(-10)) call abort()
72
73p => l()
74if (p(-11)/=11) call abort()
75
76contains
77
78  function a()
79    procedure(integer),pointer :: a
80    a => iabs
81  end function
82
83  function b()
84    procedure(integer) :: b
85    pointer :: b
86    b => iabs
87  end function
88
89  function c()
90    pointer :: c
91    procedure(integer) :: c
92    c => iabs
93  end function
94
95  function d()
96    pointer :: d
97    external d
98    d => sub
99  end function
100
101  function dd()
102    pointer :: dd
103    external :: dd
104    integer :: dd
105    dd => iabs
106  end function
107
108  function e(arg)
109    external :: e,arg
110    pointer :: e
111    e => arg
112  end function
113
114  function ee()
115    integer :: ee
116    external :: ee
117    pointer :: ee
118    ee => iabs
119  end function
120
121  function f()
122    pointer :: f
123    interface
124      integer function f(x)
125        integer,intent(in) :: x
126      end function
127    end interface
128    f => iabs
129  end function
130
131  function g()
132    interface
133      integer function g(x)
134        integer,intent(in) :: x
135      end function g
136    end interface
137    pointer :: g
138    g => iabs
139  end function
140
141  function h(arg)
142    interface
143      subroutine arg(b)
144        integer,intent(inout) :: b
145      end subroutine arg
146    end interface
147    pointer :: h
148    interface
149      subroutine h(a)
150        integer,intent(inout) :: a
151      end subroutine h
152    end interface
153    h => arg
154  end function
155
156  function i()
157    pointer :: i
158    interface
159      function i(x)
160        integer :: i,x
161        intent(in) :: x
162      end function i
163    end interface
164    i => iabs
165  end function
166
167  function k(arg)
168    procedure(integer),pointer :: k,arg
169    k => iabs
170    arg => k
171  end function
172
173  function l()
174    ! we cannot use iabs directly as it is elemental
175    abstract interface
176      pure function interf_iabs(x)
177        integer, intent(in) :: x
178      end function interf_iabs
179    end interface
180    procedure(interf_iabs),pointer :: l
181    integer :: i
182    l => iabs
183    if (l(-11)/=11) call abort()
184  end function
185
186end
187