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