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) STOP 1
  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) STOP 2
  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) STOP 3
  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)) STOP 4
  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)) STOP 5
  60     else
  61       if (.not. associated(a)) STOP 6
  62     end if
  63     if (.not. present(a)) STOP 7
  64     if (prsnt .neqv. present(b)) STOP 8
  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) STOP 9
  77     if (size(low) /= rnk .or. size(high) /= rnk) STOP 10
  78     if (size(a) /= product (high - low +1)) STOP 11
  79
  80     if (rnk > 0) then
  81       if (low(1) /= lbound(a,1)) STOP 12
  82       if (high(1) /= ubound(a,1)) STOP 13
  83       if (size (a,1) /= high(1)-low(1)+1) STOP 14
  84     end if
  85
  86     do i = 1, rnk
  87       if (low(i) /= lbound(a,i)) STOP 15
  88       if (high(i) /= ubound(a,i)) STOP 16
  89       if (size (a,i) /= high(i)-low(i)+1) STOP 17
  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) STOP 18
 103     if (size(low) /= rnk .or. size(high) /= rnk) STOP 19
 104     if (size(a) /= product (high - low +1)) STOP 20
 105
 106     if (rnk > 0) then
 107       if (1 /= lbound(a,1)) STOP 21
 108       if (high(1)-low(1)+1 /= ubound(a,1)) STOP 22
 109       if (size (a,1) /= high(1)-low(1)+1) STOP 23
 110     end if
 111
 112     do i = 1, rnk
 113       if (1 /= lbound(a,i)) STOP 24
 114       if (high(i)-low(i)+1 /= ubound(a,i)) STOP 25
 115       if (size (a,i) /= high(i)-low(i)+1) STOP 26
 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) STOP 27
 128     if (size(low) /= rnk .or. size(high) /= rnk) STOP 28
 129     if (size(a) /= product (high - low +1)) STOP 29
 130
 131     if (rnk > 0) then
 132       if (low(1) /= lbound(a,1)) STOP 30
 133       if (high(1) /= ubound(a,1)) STOP 31
 134       if (size (a,1) /= high(1)-low(1)+1) STOP 32
 135     end if
 136
 137     do i = 1, rnk
 138       if (low(i) /= lbound(a,i)) STOP 33
 139       if (high(i) /= ubound(a,i)) STOP 34
 140       if (size (a,i) /= high(i)-low(i)+1) STOP 35
 141     end do
 142     call check_value (a, rnk, val)
 143     call foo(a, rnk, low, high, val)
 144   end subroutine
 145 end