gcc/testsuite/gfortran.dg/proc_ptr_52.f90

! { dg-do run }
!
! Test the fix for PRs93924 & 93925.
!
! Contributed by Martin Stein  <mscfd@gmx.net>
!
module cs

implicit none

integer, target :: integer_target

abstract interface
   function classStar_map_ifc(x) result(y)
      class(*), pointer            :: y
      class(*), target, intent(in) :: x
   end function classStar_map_ifc
end interface

contains

   function fun(x) result(y)
      class(*), pointer            :: y
      class(*), target, intent(in) :: x
      select type (x)
      type is (integer)
         integer_target = x        ! Deals with dangling target.
         y => integer_target
      class default
         y => null()
      end select
   end function fun

   function apply(f, x) result(y)
      procedure(classStar_map_ifc) :: f
      integer, intent(in) :: x
      integer :: y
      class(*), pointer :: p
      y = 0                        ! Get rid of 'y' undefined warning
      p => f (x)
      select type (p)
      type is (integer)
         y = p
      end select
   end function apply

   function selector() result(f)
      procedure(classStar_map_ifc), pointer :: f
      f => fun
   end function selector

end module cs


program classStar_map

use cs
implicit none

integer :: x, y
procedure(classStar_map_ifc), pointer :: f

x = 123654
f => selector ()               ! Fixed by second chunk in patch
y = apply (f, x)               ! Fixed by first chunk in patch
if (x .ne. y) stop 1

x = 2 * x
y = apply (fun, x)             ! PR93925; fixed as above
if (x .ne. y) stop 2

end program classStar_map