gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90

   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
  10 module 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
  21 contains
  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
  33 end module store_subroutine
  34
  35 program 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
  46 end program test
  47
  48 recursive 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)
  54 end subroutine my_sub