121 lines
2.6 KiB
Fortran
121 lines
2.6 KiB
Fortran
! { 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" } }
|
|
|