1!{ dg-do run }
2!
3! PR 36704: Procedure pointer as function result
4!
5! Original test case from James Van Buskirk.
6!
7! Adapted by Janus Weil <janus@gcc.gnu.org>
8
9module store_subroutine
10   implicit none
11
12   abstract interface
13      subroutine sub(i)
14        integer, intent(inout) :: i
15      end subroutine sub
16   end interface
17
18   procedure(sub), pointer, private :: psub => NULL()
19
20contains
21
22   subroutine set_sub(x)
23      procedure(sub) x
24      psub => x
25   end subroutine set_sub
26
27   function get_sub()
28      procedure(sub), pointer :: get_sub
29      get_sub => psub
30   end function get_sub
31
32end module store_subroutine
33
34program test
35   use store_subroutine
36   implicit none
37   procedure(sub), pointer :: qsub
38   integer :: k = 1
39
40   call my_sub(k)
41   if (k/=3) call abort
42   qsub => get_sub()
43   call qsub(k)
44   if (k/=9) call abort
45end program test
46
47recursive subroutine my_sub(j)
48   use store_subroutine
49   implicit none
50   integer, intent(inout) :: j
51   j = j*3
52   call set_sub(my_sub)
53end subroutine my_sub
54