gcc/testsuite/gfortran.dg/select_rank_1.f90

   1 ! { dg-do run }
   2 !
   3 ! Basic tests of SELECT RANK
   4 !
   5 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   6 !
   7   implicit none
   8   type mytype
   9     real :: r
  10   end type
  11   type, extends(mytype) :: thytype
  12     integer :: i
  13   end type
  14
  15 ! Torture using integers
  16 ints: block
  17   integer, dimension(2,2) :: y = reshape ([1,2,3,4],[2,2])
  18   integer, dimension(4) :: z = [1,2,3,4]
  19   integer, dimension(2,2,2) :: q = reshape ([11,12,13,14,15,16,17,18],[2,2,2])
  20   integer :: i = 42
  21
  22   call ifoo(y, "y")
  23   if (any (y .ne. reshape ([10,11,12,13], [2,2]))) stop 1
  24   call ifoo(z, "z")
  25   call ifoo(i, "i")
  26   call ifoo(q, "q")
  27   if (any (q .ne. reshape ([11,12,10,11,15,16,12,13], [2,2,2]))) stop 2
  28   call ibar(y)
  29 end block ints
  30
  31 ! Check derived types
  32 types: block
  33   integer :: i
  34   type(mytype), allocatable, dimension(:,:) :: t
  35   type(mytype), allocatable :: u
  36
  37   allocate (t, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2]))
  38   call tfoo(t, "t")
  39   if (any (size (t) .ne. [1,1])) stop 3   ! 't' has been reallocated!
  40   if (abs (t(1,1)%r - 42.0) .ge. 1e-6) stop 4
  41   allocate (u, source = mytype(42.0))
  42   call tfoo(u, "u")
  43 end block types
  44
  45 ! Check classes
  46 classes: block
  47   integer :: i
  48   class(mytype), allocatable, dimension(:,:) :: v
  49   class(mytype), allocatable :: w
  50
  51   allocate (v, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2]))
  52   call cfoo(v, "v")
  53   select type (v)
  54     type is (mytype)
  55       stop 5
  56     type is (thytype)
  57       if (any (ubound (v) .ne. [3,3])) stop 6
  58       if (any (abs (v%r - 99.0) .ge. 1e-6)) stop 7
  59       if (any (v%i .ne. 42)) stop 8
  60   end select
  61   allocate (w, source = thytype(42.0, 99))
  62   call cfoo(w, "w")
  63 end block classes
  64
  65 ! Check unlimited polymorphic.
  66 unlimited: block
  67   integer(4) :: i
  68   class(*), allocatable, dimension(:,:,:) :: v
  69
  70   allocate (v, source = reshape ([(i, i = 1,8)],[2,2,2]))
  71   call ufoo(v, "v")
  72   select type (v)
  73     type is (integer(4))
  74       stop 9
  75     type is (real(4))
  76       if (any (ubound(v) .ne. [2,2,1])) stop 10
  77       if (abs (sum (v) - 10.0) .gt. 1e-6) stop 11
  78   end select
  79 end block unlimited
  80
  81 contains
  82
  83   recursive subroutine ifoo(w, chr)
  84     integer, dimension(..) :: w
  85     character(1) :: chr
  86
  87     OUTER: select rank (x => w)
  88       rank (2)
  89         if ((chr .eq. 'y') .and. (any (x(1,:) .ne. [1,3]))) stop 12
  90         if ((chr .eq. 'r') .and. (any (x(1,:) .ne. [13,17]))) stop 13
  91         x = reshape ([10,11,12,13], [2,2])
  92       rank (0)
  93         if ((chr .eq. 'i') .and. (x .ne. 42)) stop 14
  94       rank (*)
  95         if ((chr .eq. 'w') .and. (any (x(1:4) .ne. [10,11,12,13]))) stop 15
  96       rank default
  97         if ((chr .eq. 'z') .and. (rank (x) .ne. 1)) stop 16
  98         if ((chr .eq. 'q') .and. (rank (x) .ne. 3)) stop 17
  99         INNER: select rank (x)
 100           rank (1) INNER
 101             if ((chr .eq. 'z') .and. (any (x(1:4) .ne. [1,2,3,4]))) stop 18
 102           rank (3) INNER
 103  ! Pass a rank 2 section otherwise an infinite loop ensues.
 104             call ifoo(x(:,2,:), 'r')
 105         end select INNER
 106     end select OUTER
 107   end subroutine ifoo
 108
 109   subroutine ibar(x)
 110     integer, dimension(*) :: x
 111
 112     call ifoo(x, "w")
 113   end subroutine ibar
 114
 115   subroutine tfoo(w, chr)
 116     type(mytype), dimension(..), allocatable :: w
 117     character(1) :: chr
 118     integer :: i
 119     type(mytype), dimension(2,2) :: r
 120
 121     select rank (x => w)
 122       rank (2)
 123         if (chr .eq. 't') then
 124           r = reshape ([(mytype(real(i)), i = 1,4)],[2,2])
 125           if (any (abs (x%r - r%r) .gt. 1e-6)) stop 19
 126           if (allocated (x)) deallocate (x)
 127           allocate (x(1,1))
 128           x(1,1) = mytype (42.0)
 129         end if
 130       rank default
 131         if ((chr .eq. 'u') .and. (rank (x) .ne. 0)) stop 20
 132     end select
 133   end subroutine tfoo
 134
 135   subroutine cfoo(w, chr)
 136     class(mytype), dimension(..), allocatable :: w
 137     character(1) :: chr
 138     integer :: i
 139     type(mytype), dimension(2,2) :: r
 140
 141     select rank (c => w)
 142       rank (2)
 143         select type (c)
 144           type is (mytype)
 145             if (chr .eq. 'v') then
 146               r = reshape ([(mytype(real(i)), i = 1,4)],[2,2])
 147               if (any (abs (c%r - r%r) .gt. 1e-6)) stop 21
 148             end if
 149           class default
 150             stop 22
 151         end select
 152         if (allocated (c)) deallocate (c)
 153         allocate (c(3,3), source = thytype (99.0, 42))
 154       rank default
 155         if ((chr .eq. 'w') .and. (rank (c) .ne. 0)) stop 23
 156     end select
 157   end subroutine cfoo
 158
 159   subroutine ufoo(w, chr)
 160     class(*), dimension(..), allocatable :: w
 161     character(1) :: chr
 162     integer :: i
 163
 164     select rank (c => w)
 165       rank (3)
 166         select type (c)
 167           type is (integer(4))
 168             if (chr .eq. 'v' .and. (sum (c) .ne. 36)) stop 24
 169           class default
 170             stop 25
 171         end select
 172         if (allocated (c)) deallocate(c)
 173         allocate (c, source = reshape ([(real(i), i = 1,4)],[2,2,1]))
 174       rank default
 175         stop 26
 176     end select
 177   end subroutine ufoo
 178
 179 end