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 9implicit none 10 11interface 12 subroutine check_value(b, n, val) 13 integer :: b(..) 14 integer, value :: n 15 integer :: val(n) 16 end subroutine 17end interface 18 19integer, target :: x(2:5,4:7), y(-4:4) 20integer, allocatable, target :: z(:,:,:,:) 21integer, allocatable :: val(:) 22integer :: i 23 24allocate(z(1:4, -2:5, 4, 10:11)) 25 26if (rank(x) /= 2) STOP 1 27val = [(2*i+3, i = 1, size(x))] 28x = reshape (val, shape(x)) 29call foo(x, rank(x), lbound(x), ubound(x), val) 30call foo2(x, rank(x), lbound(x), ubound(x), val) 31call bar(x,x,.true.) 32call bar(x,prsnt=.false.) 33 34if (rank(y) /= 1) STOP 2 35val = [(2*i+7, i = 1, size(y))] 36y = reshape (val, shape(y)) 37call foo(y, rank(y), lbound(y), ubound(y), val) 38call foo2(y, rank(y), lbound(y), ubound(y), val) 39call bar(y,y,.true.) 40call bar(y,prsnt=.false.) 41 42if (rank(z) /= 4) STOP 3 43val = [(2*i+5, i = 1, size(z))] 44z(:,:,:,:) = reshape (val, shape(z)) 45call foo(z, rank(z), lbound(z), ubound(z), val) 46call foo(z, rank(z), lbound(z), ubound(z), val) 47call foo2(z, rank(z), lbound(z), ubound(z), val) 48call bar(z,z,.true.) 49call bar(z,prsnt=.false.) 50 51contains 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 145end 146