summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90
blob: b904a2f86aafd6a02e8d9fdf5912a14c6148320a (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
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
118
119
120
! { 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

! { dg-final { cleanup-modules "expressions process_libraries hard_interactions" } }