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