gcc/testsuite/gfortran.dg/proc_ptr_comp_14.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 41022: [F03] procedure pointer components as actual arguments
   4 !
   5 ! Contributed by Juergen Reuter <reuter@physik.uni-freiburg.de>
   6
   7 program foo
   8
   9    type :: container_t
  10       procedure(proc), nopass, pointer :: proc => null ()
  11    end type container_t
  12
  13    type(container_t), target :: obj1
  14    type(container_t) :: obj2
  15
  16    obj1%proc => proc
  17    call transfer_proc_ptr (obj2, obj1)
  18
  19    if (obj2%proc()/=7) call abort()
  20
  21 contains
  22
  23    subroutine transfer_proc_ptr (obj2, obj1)
  24      type(container_t), intent(out) :: obj2
  25      type(container_t), intent(in), target :: obj1
  26      call assign_proc_ptr (obj2%proc, obj1)
  27    end subroutine transfer_proc_ptr
  28
  29    subroutine assign_proc_ptr (ptr, obj1)
  30      procedure(proc), pointer :: ptr
  31      type(container_t), intent(in), target :: obj1
  32      ptr => obj1%proc
  33    end subroutine assign_proc_ptr
  34
  35    integer function proc ()
  36       proc = 7
  37    end function
  38
  39 end program foo
  40