gcc/testsuite/gfortran.dg/pointer_assign_8.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/57530
   4 !
   5 !
   6 ! TYPE => CLASS pointer assignment for variables
   7 !
   8 module m
   9   implicit none
  10   type t
  11     integer :: ii = 55
  12   end type t
  13 contains
  14   subroutine sub (tgt, tgt2)
  15     class(t), target :: tgt, tgt2(:)
  16     type(t), pointer :: ptr, ptr2(:), ptr3(:,:)
  17
  18     if (tgt%ii /= 43) call abort()
  19     if (size (tgt2) /= 3) call abort()
  20     if (any (tgt2(:)%ii /= [11,22,33])) call abort()
  21
  22     ptr => tgt  ! TYPE => CLASS
  23     ptr2 => tgt2  ! TYPE => CLASS
  24     ptr3(-3:-3,1:3) => tgt2  ! TYPE => CLASS
  25
  26     if (.not. associated(ptr)) call abort()
  27     if (.not. associated(ptr2)) call abort()
  28     if (.not. associated(ptr3)) call abort()
  29     if (.not. associated(ptr,tgt)) call abort()
  30     if (.not. associated(ptr2,tgt2)) call abort()
  31     if (ptr%ii /= 43) call abort()
  32     if (size (ptr2) /= 3) call abort()
  33     if (size (ptr3) /= 3) call abort()
  34     if (any (ptr2(:)%ii /= [11,22,33])) call abort()
  35     if (any (shape (ptr3) /= [1,3])) call abort()
  36     if (any (ptr3(-3,:)%ii /= [11,22,33])) call abort()
  37   end subroutine sub
  38 end module m
  39
  40 use m
  41 type(t), target :: x
  42 type(t), target :: y(3)
  43 x%ii = 43
  44 y(:)%ii = [11,22,33]
  45 call sub(x,y)
  46 end