gcc/testsuite/gfortran.dg/select_type_27.f03

   1 ! { dg-do run }
   2 ! Tests fix for PR41600 and further SELECT TYPE functionality.
   3 ! This differs from the original and select_type_26.f03 by 'm'
   4 ! being a class object rather than a derived type.
   5 !
   6 ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
   7 !
   8   implicit none
   9   type t0
  10     integer :: j = 42
  11   end type t0
  12
  13   type, extends(t0) :: t1
  14     integer :: k = 99
  15   end type t1
  16
  17   type t
  18     integer :: i
  19     class(t0), allocatable :: foo(:)
  20   end type t
  21
  22   type t_scalar
  23     integer :: i
  24     class(t0), allocatable :: foo
  25   end type t_scalar
  26
  27   class(t), allocatable :: m
  28   class(t_scalar), allocatable :: m1(:)
  29   integer :: n
  30
  31   allocate (m)
  32   allocate (m1(4))
  33
  34 ! Test the fix for PR41600 itself - first with m%foo of declared type.
  35   allocate(m%foo(3), source = [(t0(n), n = 1,3)])
  36   select type(bar => m%foo)
  37     type is(t0)
  38       if (any (bar%j .ne. [1,2,3])) call abort
  39     type is(t1)
  40       call abort
  41   end select
  42
  43   deallocate(m%foo)
  44   allocate(m%foo(3), source = [(t1(n, n*10), n = 4,6)])
  45
  46 ! Then with m%foo of another dynamic type.
  47   select type(bar => m%foo)
  48     type is(t0)
  49       call abort
  50     type is(t1)
  51       if (any (bar%k .ne. [40,50,60])) call abort
  52   end select
  53
  54 ! Try it with a selector array section.
  55   select type(bar => m%foo(2:3))
  56     type is(t0)
  57       call abort
  58     type is(t1)
  59       if (any (bar%k .ne. [50,60])) call abort
  60   end select
  61
  62 ! Try it with a selector array element.
  63   select type(bar => m%foo(2))
  64     type is(t0)
  65       call abort
  66     type is(t1)
  67       if (bar%k .ne. 50) call abort
  68   end select
  69
  70 ! Now try class is and a selector which is an array section of an associate name.
  71   select type(bar => m%foo)
  72     type is(t0)
  73       call abort
  74     class is (t1)
  75       if (any (bar%j .ne. [4,5,6])) call abort
  76       select type (foobar => bar(3:2:-1))
  77         type is (t1)
  78           if (any (foobar%k .ne. [60,50])) call abort
  79         end select
  80   end select
  81
  82 ! Now try class is and a selector which is an array element of an associate name.
  83   select type(bar => m%foo)
  84     type is(t0)
  85       call abort
  86     class is (t1)
  87       if (any (bar%j .ne. [4,5,6])) call abort
  88       select type (foobar => bar(2))
  89         type is (t1)
  90           if (foobar%k .ne. 50) call abort
  91         end select
  92   end select
  93
  94 ! Check class a component of an element of an array. Note that an array of such
  95 ! objects cannot be allowed since the elements could have different dynamic types.
  96 ! (F2003 C614)
  97   do n = 1, 2
  98     allocate(m1(n)%foo, source = t1(n*99, n*999))
  99   end do
 100   do n = 3, 4
 101     allocate(m1(n)%foo, source = t0(n*99))
 102   end do
 103   select type(bar => m1(3)%foo)
 104     type is(t0)
 105       if (bar%j .ne. 297) call abort
 106     type is(t1)
 107       call abort
 108   end select
 109   select type(bar => m1(1)%foo)
 110     type is(t0)
 111       call abort
 112     type is(t1)
 113       if (bar%k .ne. 999) call abort
 114   end select
 115 end