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