gcc/testsuite/gfortran.dg/pr88932.f90

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