gcc/testsuite/gfortran.dg/proc_ptr_comp_23.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR42104 in which the call to the procedure pointer
   3 ! component caused an ICE because the "always_implicit flag was not used
   4 ! to force the passing of a descriptor for the array argument.
   5 !
   6 ! Contributed by Martien Hulsen <m.a.hulsen@tue.nl>
   7 !
   8 module poisson_functions_m
   9
  10   implicit none
  11
  12 contains
  13
  14   function func ( nr, x )
  15     integer, intent(in) :: nr
  16     real, intent(in), dimension(:) :: x
  17     real :: func
  18
  19     real :: pi
  20
  21     pi = 4 * atan(1.)
  22
  23     select case(nr)
  24       case(1)
  25         func = 0
  26       case(2)
  27         func = 1
  28       case(3)
  29         func = 1 + cos(pi*x(1))*cos(pi*x(2))
  30       case default
  31         write(*,'(/a,i0/)') 'Error func: wrong function number: ', nr
  32         stop
  33     end select
  34
  35   end function func
  36
  37 end module poisson_functions_m
  38
  39 module element_defs_m
  40
  41   implicit none
  42
  43   abstract interface
  44     function dummyfunc ( nr, x )
  45       integer, intent(in) :: nr
  46       real, intent(in), dimension(:) :: x
  47       real :: dummyfunc
  48     end function dummyfunc
  49   end interface
  50
  51   type function_p
  52     procedure(dummyfunc), nopass, pointer :: p => null()
  53   end type function_p
  54
  55 end module element_defs_m
  56
  57 program t
  58
  59 use poisson_functions_m
  60 use element_defs_m
  61
  62 procedure(dummyfunc), pointer :: p => null()
  63 type(function_p) :: funcp
  64
  65 p => func
  66 funcp%p => func
  67
  68 print *, func(nr=3,x=(/0.1,0.1/))
  69 print *, p(nr=3,x=(/0.1,0.1/))
  70 print *, funcp%p(nr=3,x=(/0.1,0.1/))
  71
  72 end program t
  73 ! { dg-final { cleanup-modules "poisson_functions_m element_defs_m" } }