gcc/testsuite/gfortran.dg/pointer_assign_11.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/57530
   4 !
   5 !
   6 ! CLASS => CLASS pointer assignment for function results
   7 !
   8 module m
   9   implicit none
  10   type t
  11     integer :: ii = 55
  12   end type t
  13   type, extends(t) :: t2
  14   end type t2
  15 contains
  16   function f1()
  17     class(t), pointer :: f1
  18     allocate (f1)
  19     f1%ii = 123
  20   end function f1
  21   function f2()
  22     class(t), pointer :: f2(:)
  23     allocate (f2(3))
  24     f2(:)%ii = [-11,-22,-33]
  25   end function f2
  26 end module m
  27
  28 program test
  29   use m
  30   implicit none
  31   class(t), pointer :: p1, p2(:), p3(:,:)
  32   type(t) :: my_t
  33   type(t2) :: my_t2
  34
  35   allocate (t2 :: p1, p2(1), p3(1,1))
  36   if (.not. same_type_as (p1, my_t2)) STOP 1
  37   if (.not. same_type_as (p2, my_t2)) STOP 2
  38   if (.not. same_type_as (p3, my_t2)) STOP 3
  39
  40   p1 => f1()
  41   if (p1%ii /= 123) STOP 4
  42   if (.not. same_type_as (p1, my_t)) STOP 5
  43
  44   p2 => f2()
  45   if (any (p2%ii /= [-11,-22,-33])) STOP 6
  46   if (.not. same_type_as (p2, my_t)) STOP 7
  47
  48   p3(2:2,1:3) => f2()
  49   if (any (p3(2,:)%ii /= [-11,-22,-33])) STOP 8
  50   if (.not. same_type_as (p3, my_t)) STOP 9
  51 end program test