gcc/testsuite/gfortran.dg/proc_ptr_result_6.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 40593: Proc-pointer returning function as actual argument
   4 !
   5 ! Original test case by Tobias Burnus <burnus@gcc.gnu.org>
   6 ! Modified by Janus Weil
   7
   8 module m
   9 contains
  10   subroutine sub(a)
  11     integer :: a
  12     a = 42
  13   end subroutine
  14   integer function func()
  15     func = 42
  16   end function
  17 end module m
  18
  19 program test
  20   use m
  21   implicit none
  22   call caller1(getPtr1())
  23   call caller2(getPtr2())
  24   call caller3(getPtr2())
  25 contains
  26   subroutine caller1(s)
  27     procedure(sub) :: s
  28     integer :: b
  29     call s(b)
  30     if (b /= 42)  call abort()
  31   end subroutine
  32   subroutine caller2(f)
  33     procedure(integer) :: f
  34     if (f() /= 42)  call abort()
  35   end subroutine
  36   subroutine caller3(f)
  37     procedure(func),pointer :: f
  38     if (f() /= 42) call abort()
  39   end subroutine
  40   function getPtr1()
  41     procedure(sub), pointer :: getPtr1
  42     getPtr1 => sub
  43   end function
  44   function getPtr2()
  45     procedure(func), pointer :: getPtr2
  46     getPtr2 => func
  47   end function
  48 end program test
  49
  50 ! { dg-final { cleanup-modules "m" } }
  51