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