Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/gfortran.dg/assumed_rank_2.f90 @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
| 68:561a7518be6b | 111:04ced10e8804 |
|---|---|
| 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 |