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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Original code by Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
!
! Adapted by Janus Weil <janus@gcc.gnu.org>
! Test for infinte recursion in trans-types.c when a PPC interface
! refers to the original type.
module expressions
type :: eval_node_t
logical, pointer :: lval => null ()
type(eval_node_t), pointer :: arg1 => null ()
procedure(unary_log), nopass, pointer :: op1_log => null ()
end type eval_node_t
abstract interface
logical function unary_log (arg)
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_log
end interface
contains
subroutine eval_node_set_op1_log (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_log) :: op
en%op1_log => op
end subroutine eval_node_set_op1_log
subroutine eval_node_evaluate (en)
type(eval_node_t), intent(inout) :: en
en%lval = en%op1_log (en%arg1)
end subroutine
end module
! Test for C_F_PROCPOINTER and pointers to derived types
module process_libraries
implicit none
type :: process_library_t
procedure(), nopass, pointer :: write_list
end type process_library_t
contains
subroutine process_library_load (prc_lib)
use iso_c_binding
type(process_library_t) :: prc_lib
type(c_funptr) :: c_fptr
call c_f_procpointer (c_fptr, prc_lib%write_list)
end subroutine process_library_load
subroutine process_libraries_test ()
type(process_library_t), pointer :: prc_lib
call prc_lib%write_list ()
end subroutine process_libraries_test
end module process_libraries
! Test for argument resolution
module hard_interactions
implicit none
type :: hard_interaction_t
procedure(), nopass, pointer :: new_event
end type hard_interaction_t
interface afv
module procedure afv_1
end interface
contains
function afv_1 () result (a)
real, dimension(0:3) :: a
end function
subroutine hard_interaction_evaluate (hi)
type(hard_interaction_t) :: hi
call hi%new_event (afv ())
end subroutine
end module hard_interactions
! Test for derived types with PPC working properly as function result.
implicit none
type :: var_entry_t
procedure(), nopass, pointer :: obs1_int
end type var_entry_t
type(var_entry_t), pointer :: var
var => var_list_get_var_ptr ()
contains
function var_list_get_var_ptr ()
type(var_entry_t), pointer :: var_list_get_var_ptr
end function var_list_get_var_ptr
end
|
