gcc/testsuite/gfortran.dg/assumed_rank_2.f90

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