gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR64578.
   3 !
   4 ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
   5 !
   6   type foo
   7      real, allocatable :: component(:)
   8   end type
   9   type (foo), target :: f
  10   class(*), pointer :: ptr(:)
  11   allocate(f%component(1),source=[0.99])
  12   call associate_pointer(f,ptr)
  13   select type (ptr)
  14     type is (real)
  15       if (abs (ptr(1) - 0.99) > 1e-5) call abort
  16   end select
  17   ptr => return_pointer(f)  ! runtime segmentation fault
  18   if (associated(return_pointer(f)) .neqv. .true.) call abort
  19   select type (ptr)
  20     type is (real)
  21       if (abs (ptr(1) - 0.99) > 1e-5) call abort
  22   end select
  23 contains
  24   subroutine associate_pointer(this, item)
  25     class(foo), target :: this
  26     class(*), pointer :: item(:)
  27     item => this%component
  28   end subroutine
  29   function return_pointer(this)
  30     class(foo), target :: this
  31     class(*), pointer :: return_pointer(:)
  32     return_pointer => this%component
  33   end function
  34 end
  35