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) call abort () 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) call abort () 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) call abort () 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)) 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 145end 146