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