summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/proc_ptr_comp_14.f90
blob: 811223ee2d116b7bfdaaf70f377b36dc8bfcbc74 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
! { dg-do run }
!
! PR 41022: [F03] procedure pointer components as actual arguments
!
! Contributed by Juergen Reuter <reuter@physik.uni-freiburg.de>

program foo

   type :: container_t
      procedure(proc), nopass, pointer :: proc => null ()
   end type container_t

   type(container_t), target :: obj1
   type(container_t) :: obj2

   obj1%proc => proc
   call transfer_proc_ptr (obj2, obj1)

   if (obj2%proc()/=7) call abort()

contains

   subroutine transfer_proc_ptr (obj2, obj1)
     type(container_t), intent(out) :: obj2
     type(container_t), intent(in), target :: obj1
     call assign_proc_ptr (obj2%proc, obj1)
   end subroutine transfer_proc_ptr

   subroutine assign_proc_ptr (ptr, obj1)
     procedure(proc), pointer :: ptr
     type(container_t), intent(in), target :: obj1
     ptr => obj1%proc
   end subroutine assign_proc_ptr

   integer function proc ()
      proc = 7
   end function

end program foo