gcc/testsuite/gfortran.dg/proc_ptr_52.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PRs93924 & 93925.
   4 !
   5 ! Contributed by Martin Stein  <mscfd@gmx.net>
   6 !
   7 module cs
   8
   9 implicit none
  10
  11 integer, target :: integer_target
  12
  13 abstract interface
  14    function classStar_map_ifc(x) result(y)
  15       class(*), pointer            :: y
  16       class(*), target, intent(in) :: x
  17    end function classStar_map_ifc
  18 end interface
  19
  20 contains
  21
  22    function fun(x) result(y)
  23       class(*), pointer            :: y
  24       class(*), target, intent(in) :: x
  25       select type (x)
  26       type is (integer)
  27          integer_target = x        ! Deals with dangling target.
  28          y => integer_target
  29       class default
  30          y => null()
  31       end select
  32    end function fun
  33
  34    function apply(f, x) result(y)
  35       procedure(classStar_map_ifc) :: f
  36       integer, intent(in) :: x
  37       integer :: y
  38       class(*), pointer :: p
  39       y = 0                        ! Get rid of 'y' undefined warning
  40       p => f (x)
  41       select type (p)
  42       type is (integer)
  43          y = p
  44       end select
  45    end function apply
  46
  47    function selector() result(f)
  48       procedure(classStar_map_ifc), pointer :: f
  49       f => fun
  50    end function selector
  51
  52 end module cs
  53
  54
  55 program classStar_map
  56
  57 use cs
  58 implicit none
  59
  60 integer :: x, y
  61 procedure(classStar_map_ifc), pointer :: f
  62
  63 x = 123654
  64 f => selector ()               ! Fixed by second chunk in patch
  65 y = apply (f, x)               ! Fixed by first chunk in patch
  66 if (x .ne. y) stop 1
  67
  68 x = 2 * x
  69 y = apply (fun, x)             ! PR93925; fixed as above
  70 if (x .ne. y) stop 2
  71
  72 end program classStar_map