gcc/testsuite/gfortran.dg/proc_ptr_result_3.f90

   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
   9 module 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
  20 contains
  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
  32 end module store_subroutine
  33
  34 program 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
  45 end program test
  46
  47 recursive 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)
  53 end subroutine my_sub