gcc/testsuite/gfortran.dg/assumed_rank_1.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources assumed_rank_1_c.c }
   3 !
   4 ! PR fortran/48820
   5 !
   6 ! Assumed-rank tests
   7 !
   8
   9 implicit none
  10
  11 interface
  12   subroutine check_value(b, n, val)
  13     integer :: b(..)
  14     integer, value :: n
  15     integer :: val(n)
  16   end subroutine
  17 end interface
  18
  19 integer, target :: x(2:5,4:7), y(-4:4)
  20 integer, allocatable, target :: z(:,:,:,:)
  21 integer, allocatable :: val(:)
  22 integer :: i
  23
  24 allocate(z(1:4, -2:5, 4, 10:11))
  25
  26 if (rank(x) /= 2) call abort ()
  27 val = [(2*i+3, i = 1, size(x))]
  28 x = reshape (val, shape(x))
  29 call foo(x, rank(x), lbound(x), ubound(x), val)
  30 call foo2(x, rank(x), lbound(x), ubound(x), val)
  31 call bar(x,x,.true.)
  32 call bar(x,prsnt=.false.)
  33
  34 if (rank(y) /= 1) call abort ()
  35 val = [(2*i+7, i = 1, size(y))]
  36 y = reshape (val, shape(y))
  37 call foo(y, rank(y), lbound(y), ubound(y), val)
  38 call foo2(y, rank(y), lbound(y), ubound(y), val)
  39 call bar(y,y,.true.)
  40 call bar(y,prsnt=.false.)
  41
  42 if (rank(z) /= 4) call abort ()
  43 val = [(2*i+5, i = 1, size(z))]
  44 z(:,:,:,:) = reshape (val, shape(z))
  45 call foo(z, rank(z), lbound(z), ubound(z), val)
  46 call foo(z, rank(z), lbound(z), ubound(z), val)
  47 call foo2(z, rank(z), lbound(z), ubound(z), val)
  48 call bar(z,z,.true.)
  49 call bar(z,prsnt=.false.)
  50
  51 contains
  52   subroutine bar(a,b, prsnt)
  53     integer, pointer, optional, intent(in) :: a(..),b(..)
  54     logical, value :: prsnt
  55     if (.not. associated(a)) call abort()
  56     if (present(b)) then
  57        ! The following is not valid.
  58        ! Technically, it could be allowed and might be in Fortran 2015:
  59        ! if (.not. associated(a,b)) call abort()
  60     else
  61       if (.not. associated(a)) call abort()
  62     end if
  63     if (.not. present(a)) call abort()
  64     if (prsnt .neqv. present(b)) call abort()
  65   end subroutine
  66
  67   ! POINTER argument - bounds as specified before
  68   subroutine foo(a, rnk, low, high, val)
  69     integer,pointer, intent(in) :: a(..)
  70     integer, value :: rnk
  71     integer, intent(in) :: low(:), high(:), val(:)
  72     integer :: i
  73
  74
  75
  76     if (rank(a) /= rnk) call abort()
  77     if (size(low) /= rnk .or. size(high) /= rnk) call abort()
  78     if (size(a) /= product (high - low +1)) call abort()
  79
  80     if (rnk > 0) then
  81       if (low(1) /= lbound(a,1)) call abort()
  82       if (high(1) /= ubound(a,1)) call abort()
  83       if (size (a,1) /= high(1)-low(1)+1) call abort()
  84     end if
  85
  86     do i = 1, rnk
  87       if (low(i) /= lbound(a,i)) call abort()
  88       if (high(i) /= ubound(a,i)) call abort()
  89       if (size (a,i) /= high(i)-low(i)+1) call abort()
  90     end do
  91     call check_value (a, rnk, val)
  92     call foo2(a, rnk, low, high, val)
  93   end subroutine
  94
  95   ! Non-pointer, non-allocatable bounds. lbound == 1
  96   subroutine foo2(a, rnk, low, high, val)
  97     integer, intent(in) :: a(..)
  98     integer, value :: rnk
  99     integer, intent(in) :: low(:), high(:), val(:)
 100     integer :: i
 101
 102     if (rank(a) /= rnk) call abort()
 103     if (size(low) /= rnk .or. size(high) /= rnk) call abort()
 104     if (size(a) /= product (high - low +1)) call abort()
 105
 106     if (rnk > 0) then
 107       if (1 /= lbound(a,1)) call abort()
 108       if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
 109       if (size (a,1) /= high(1)-low(1)+1) call abort()
 110     end if
 111
 112     do i = 1, rnk
 113       if (1 /= lbound(a,i)) call abort()
 114       if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
 115       if (size (a,i) /= high(i)-low(i)+1) call abort()
 116     end do
 117     call check_value (a, rnk, val)
 118   end subroutine foo2
 119
 120   ! ALLOCATABLE argument - bounds as specified before
 121   subroutine foo3 (a, rnk, low, high, val)
 122     integer, allocatable, intent(in), target :: a(..)
 123     integer, value :: rnk
 124     integer, intent(in) :: low(:), high(:), val(:)
 125     integer :: i
 126
 127     if (rank(a) /= rnk) call abort()
 128     if (size(low) /= rnk .or. size(high) /= rnk) call abort()
 129     if (size(a) /= product (high - low +1)) call abort()
 130
 131     if (rnk > 0) then
 132       if (low(1) /= lbound(a,1)) call abort()
 133       if (high(1) /= ubound(a,1)) call abort()
 134       if (size (a,1) /= high(1)-low(1)+1) call abort()
 135     end if
 136
 137     do i = 1, rnk
 138       if (low(i) /= lbound(a,i)) call abort()
 139       if (high(i) /= ubound(a,i)) call abort()
 140       if (size (a,i) /= high(i)-low(i)+1) call abort()
 141     end do
 142     call check_value (a, rnk, val)
 143     call foo(a, rnk, low, high, val)
 144   end subroutine
 145 end