gcc/testsuite/gfortran.dg/pointer_array_4.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR57116 as part of the overall fix for PR34640.
   4 !
   5 ! Contributed by Reinhold Bader  <Bader@lrz.de>
   6 !
   7 module mod_rtti_ptr
   8   implicit none
   9   type :: foo
  10      real :: v
  11      integer :: i
  12   end type foo
  13 contains
  14   subroutine extract(this, v, ic)
  15     class(*), target :: this(:)
  16     real, pointer :: v(:)
  17     integer :: ic
  18     select type (this)
  19     type is (real)
  20        v => this(ic:)
  21     class is (foo)
  22        v => this(ic:)%v
  23     end select
  24   end subroutine extract
  25 end module
  26
  27 program prog_rtti_ptr
  28   use mod_rtti_ptr
  29   class(*), allocatable, target :: o(:)
  30   real, pointer :: v(:)
  31
  32   allocate(o(3), source=[1.0, 2.0, 3.0])
  33   call extract(o, v, 2)
  34   if (size(v) == 2 .and. all (v == [2.0, 3.0])) then
  35      deallocate(o)
  36   else
  37      STOP 1
  38   end if
  39
  40   allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)])
  41   call extract(o, v, 2)
  42   if (size(v) == 2 .and. all (v == [4.0, 5.0])) then
  43      deallocate(o)
  44   else
  45      STOP 2
  46   end if
  47
  48 ! The rest tests the case in comment 2 <janus@gcc.gnu.org>
  49
  50   call extract1 (v, 1)
  51   if (any (v /= [1.0, 2.0])) STOP 3
  52   call extract1 (v, 2)  ! Call to deallocate pointer.
  53
  54 contains
  55   subroutine extract1(v, flag)
  56     type :: foo
  57        real :: v
  58        character(4) :: str
  59     end type
  60     class(foo), pointer, save :: this(:)
  61     real, pointer :: v(:)
  62     integer :: flag
  63
  64     if (flag == 1) then
  65       allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")])
  66       select type (this)
  67         class is (foo)
  68           v => this(1:2)%v
  69       end select
  70     else
  71       deallocate (this)
  72     end if
  73   end subroutine
  74
  75 end program prog_rtti_ptr