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
|
