gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90

   1 ! { dg-do run }
   2 !
   3 ! This test case is inserted as a check. PR89365 inially asserted that
   4 ! gfortran was getting the bounds wrong for allocatable and pointer
   5 ! actual arguments. However, the reporter accepted that it is OK and
   6 ! this is the corrected version of his testcase, which fills a gap in
   7 ! the testsuite.
   8 !
   9 ! Contributed by Reinhold Bader  <Bader@lrz.de>
  10 !
  11 module mod_ass_rank_inquiry
  12   use, intrinsic :: iso_c_binding
  13   implicit none
  14   logical, parameter :: debug = .true.
  15   integer :: error_count = 0
  16 !
  17 ! using inquiry functions for assumed rank objects
  18 !
  19   contains
  20     subroutine foo_1(this)
  21       real(c_float) :: this(..)
  22       select case(rank(this))
  23       case(0)
  24          if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
  25               size(ubound(this)) > 0) then
  26             error_count = error_count + 1
  27             if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
  28          end if
  29          if (size(this) /= 1) then
  30             error_count = error_count + 1
  31             if (debug) write(*,*) 'FAIL size'
  32          end if
  33       case(1)
  34          if (sum(abs(shape(this) -  [4])) > 0) then
  35             error_count = error_count + 1
  36             if (debug) write(*,*) 'FAIL shape'
  37          end if
  38          if (size(this) /= 4) then
  39             error_count = error_count + 1
  40             if (debug) write(*,*) 'FAIL size', size(this)
  41          end if
  42          if (lbound(this,1) /= 1) then
  43             error_count = error_count + 1
  44             if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
  45          end if
  46          if (ubound(this,1) /= 4) then
  47             error_count = error_count + 1
  48             if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
  49          end if
  50       case(3)
  51          if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
  52             error_count = error_count + 1
  53             if (debug) write(*,*) 'FAIL shape'
  54          end if
  55          if (size(this) /= 2*3*4) then
  56             error_count = error_count + 1
  57             if (debug) write(*,*) 'FAIL size'
  58          end if
  59          if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then
  60             error_count = error_count + 1
  61             if (debug) write(*,*) 'FAIL lbound'
  62          end if
  63          if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
  64             error_count = error_count + 1
  65             if (debug) write(*,*) 'FAIL ubound'
  66          end if
  67       case default
  68          error_count = error_count + 1
  69       end select
  70     end subroutine foo_1
  71     subroutine foo_2(this)
  72       real(c_float), allocatable :: this(..)
  73       if (.not. allocated(this)) then
  74          error_count = error_count + 1
  75          if (debug) write(*,*) 'FAIL allocated'
  76       end if
  77       select case(rank(this))
  78       case(0)
  79          if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
  80               size(ubound(this)) > 0) then
  81             error_count = error_count + 1
  82             if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
  83          end if
  84          if (size(this) /= 1) then
  85             error_count = error_count + 1
  86             if (debug) write(*,*) 'FAIL size'
  87          end if
  88       case(1)
  89          if (sum(abs(shape(this) -  [4])) > 0) then
  90             error_count = error_count + 1
  91             if (debug) write(*,*) 'FAIL shape'
  92          end if
  93          if (size(this) /= 4) then
  94             error_count = error_count + 1
  95             if (debug) write(*,*) 'FAIL size', size(this)
  96          end if
  97          if (lbound(this,1) /= 2) then
  98             error_count = error_count + 1
  99             if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
 100          end if
 101          if (ubound(this,1) /= 5) then
 102             error_count = error_count + 1
 103             if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
 104          end if
 105       case(3)
 106          if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
 107             error_count = error_count + 1
 108             if (debug) write(*,*) 'FAIL shape'
 109          end if
 110          if (size(this) /= 2*3*4) then
 111             error_count = error_count + 1
 112             if (debug) write(*,*) 'FAIL size'
 113          end if
 114          if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
 115             error_count = error_count + 1
 116             if (debug) write(*,*) 'FAIL lbound', lbound(this)
 117          end if
 118          if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
 119             error_count = error_count + 1
 120             if (debug) write(*,*) 'FAIL ubound', ubound(this)
 121          end if
 122       case default
 123          error_count = error_count + 1
 124       end select
 125     end subroutine foo_2
 126     subroutine foo_3(this)
 127       real(c_float), pointer :: this(..)
 128       if (.not. associated(this)) then
 129          error_count = error_count + 1
 130          if (debug) write(*,*) 'FAIL associated'
 131       end if
 132       select case(rank(this))
 133       case(0)
 134          if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
 135               size(ubound(this)) > 0) then
 136             error_count = error_count + 1
 137             if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
 138          end if
 139          if (size(this) /= 1) then
 140             error_count = error_count + 1
 141             if (debug) write(*,*) 'FAIL size'
 142          end if
 143       case(1)
 144          if (sum(abs(shape(this) -  [4])) > 0) then
 145             error_count = error_count + 1
 146             if (debug) write(*,*) 'FAIL shape'
 147          end if
 148          if (size(this) /= 4) then
 149             error_count = error_count + 1
 150             if (debug) write(*,*) 'FAIL size', size(this)
 151          end if
 152          if (lbound(this,1) /= 2) then
 153             error_count = error_count + 1
 154             if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
 155          end if
 156          if (ubound(this,1) /= 5) then
 157             error_count = error_count + 1
 158             if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
 159          end if
 160       case(3)
 161          if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
 162             error_count = error_count + 1
 163             if (debug) write(*,*) 'FAIL shape'
 164          end if
 165          if (size(this) /= 2*3*4) then
 166             error_count = error_count + 1
 167             if (debug) write(*,*) 'FAIL size'
 168          end if
 169          if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
 170             error_count = error_count + 1
 171             if (debug) write(*,*) 'FAIL lbound', lbound(this)
 172          end if
 173          if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
 174             error_count = error_count + 1
 175             if (debug) write(*,*) 'FAIL ubound', ubound(this)
 176          end if
 177       case default
 178          error_count = error_count + 1
 179       end select
 180     end subroutine foo_3
 181 end module mod_ass_rank_inquiry
 182 program ass_rank_inquiry
 183   use mod_ass_rank_inquiry
 184   implicit none
 185   real, allocatable :: x, y(:), z(:,:,:)
 186   real, pointer :: xp, yp(:), zp(:,:,:)
 187
 188   allocate(x, y(2:5), z(0:1,-1:1,1:4))
 189   allocate(xp, yp(2:5), zp(0:1,-1:1,1:4))
 190
 191
 192   call foo_1(x)
 193   if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count
 194   call foo_1(y)
 195   if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count
 196   call foo_1(z)
 197   if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count
 198   call foo_2(x)
 199   if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count
 200   call foo_2(y)
 201   if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count
 202   call foo_2(z)
 203   if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count
 204   call foo_3(xp)
 205   if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count
 206   call foo_3(yp)
 207   if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count
 208   call foo_3(zp)
 209   if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count
 210
 211   if (error_count == 0) then
 212     write(*,*) 'OK'
 213   else
 214     stop 1
 215   end if
 216
 217   deallocate(x, y, z)
 218   deallocate(xp, yp, zp)
 219 end program ass_rank_inquiry