gcc/testsuite/gfortran.dg/proc_ptr_comp_4.f90

   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
  13 module 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
  28 contains
  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
  41 end module
  42
  43
  44 ! Test for C_F_PROCPOINTER and pointers to derived types
  45
  46 module 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
  54 contains
  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
  68 end module process_libraries
  69
  70
  71 ! Test for argument resolution
  72
  73 module 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
  85 contains
  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
  96 end 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
 111 contains
 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
 117 end