gcc/testsuite/gfortran.dg/select_type_26.f03

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