gcc/testsuite/gfortran.dg/assumed_rank_7.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/48820
   4 !
   5 ! Handle type/class for assumed-rank arrays
   6 !
   7 ! FIXME: Passing a CLASS to a CLASS has to be re-enabled.
   8 implicit none
   9 type t
  10   integer :: i
  11 end type
  12
  13 class(T), allocatable :: ac(:,:)
  14 type(T), allocatable :: at(:,:)
  15 integer :: i
  16
  17 allocate(ac(2:3,2:4))
  18 allocate(at(2:3,2:4))
  19
  20 i = 0
  21 call foo(ac)
  22 call foo(at)
  23 call bar(ac)
  24 call bar(at)
  25 if (i /= 12) STOP 1
  26
  27 contains
  28   subroutine bar(x)
  29     type(t) :: x(..)
  30     if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 2
  31     if (size(x) /= 6) STOP 3
  32     if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 4
  33     if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 5
  34     i = i + 1
  35     call foo(x)
  36     call bar2(x)
  37   end subroutine
  38   subroutine bar2(x)
  39     type(t) :: x(..)
  40     if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 6
  41     if (size(x) /= 6) STOP 7
  42     if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 8
  43     if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 9
  44     i = i + 1
  45   end subroutine
  46   subroutine foo(x)
  47     class(t) :: x(..)
  48     if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 10
  49     if (size(x) /= 6) STOP 11
  50     if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 12
  51     if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 13
  52     i = i + 1
  53     call foo2(x)
  54 !    call bar2(x) ! Passing a CLASS to a TYPE does not yet work
  55   end subroutine
  56   subroutine foo2(x)
  57     class(t) :: x(..)
  58     if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 14
  59     if (size(x) /= 6) STOP 15
  60     if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 16
  61     if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 17
  62     i = i + 1
  63   end subroutine
  64 end