re PR fortran/89365 (Inquiry functions for assumed rank objects fail)

2019-06-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89365
	* gfortran.dg/assumed_rank_bounds_3.f90 : New test.

From-SVN: r272090

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index df3d0061b5008c9f942b8629c8cfdd151550983b..a1b884164de936a22c2d95d9836559bb8749cc1b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+019-06-09  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/89365
+       * gfortran.dg/assumed_rank_bounds_3.f90 : New test.
+
 2019-06-08  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/90786

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90
new file mode 100644 (file)
index 0000000..0a428f2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90
@@ -0,0 +1,219 @@
+! { dg-do run }
+!
+! This test case is inserted as a check. PR89365 inially asserted that
+! gfortran was getting the bounds wrong for allocatable and pointer
+! actual arguments. However, the reporter accepted that it is OK and
+! this is the corrected version of his testcase, which fills a gap in
+! the testsuite.
+!
+! Contributed by Reinhold Bader  <Bader@lrz.de>
+!
+module mod_ass_rank_inquiry
+  use, intrinsic :: iso_c_binding
+  implicit none
+  logical, parameter :: debug = .true.
+  integer :: error_count = 0
+!
+! using inquiry functions for assumed rank objects
+!
+  contains
+    subroutine foo_1(this)
+      real(c_float) :: this(..)
+      select case(rank(this))
+      case(0)
+         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
+              size(ubound(this)) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
+         end if
+         if (size(this) /= 1) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+      case(1)
+         if (sum(abs(shape(this) -  [4])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size', size(this)
+         end if
+         if (lbound(this,1) /= 1) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
+         end if
+         if (ubound(this,1) /= 4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
+         end if
+      case(3)
+         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 2*3*4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+         if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound'
+         end if
+         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound'
+         end if
+      case default
+         error_count = error_count + 1
+      end select
+    end subroutine foo_1
+    subroutine foo_2(this)
+      real(c_float), allocatable :: this(..)
+      if (.not. allocated(this)) then
+         error_count = error_count + 1
+         if (debug) write(*,*) 'FAIL allocated'
+      end if
+      select case(rank(this))
+      case(0)
+         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
+              size(ubound(this)) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
+         end if
+         if (size(this) /= 1) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+      case(1)
+         if (sum(abs(shape(this) -  [4])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size', size(this)
+         end if
+         if (lbound(this,1) /= 2) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
+         end if
+         if (ubound(this,1) /= 5) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
+         end if
+      case(3)
+         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 2*3*4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+         if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound', lbound(this)
+         end if
+         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound', ubound(this)
+         end if
+      case default
+         error_count = error_count + 1
+      end select
+    end subroutine foo_2
+    subroutine foo_3(this)
+      real(c_float), pointer :: this(..)
+      if (.not. associated(this)) then
+         error_count = error_count + 1
+         if (debug) write(*,*) 'FAIL associated'
+      end if
+      select case(rank(this))
+      case(0)
+         if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
+              size(ubound(this)) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape / lbound  / ubound'
+         end if
+         if (size(this) /= 1) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+      case(1)
+         if (sum(abs(shape(this) -  [4])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size', size(this)
+         end if
+         if (lbound(this,1) /= 2) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
+         end if
+         if (ubound(this,1) /= 5) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
+         end if
+      case(3)
+         if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL shape'
+         end if
+         if (size(this) /= 2*3*4) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL size'
+         end if
+         if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL lbound', lbound(this)
+         end if
+         if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
+            error_count = error_count + 1
+            if (debug) write(*,*) 'FAIL ubound', ubound(this)
+         end if
+      case default
+         error_count = error_count + 1
+      end select
+    end subroutine foo_3
+end module mod_ass_rank_inquiry
+program ass_rank_inquiry
+  use mod_ass_rank_inquiry
+  implicit none
+  real, allocatable :: x, y(:), z(:,:,:)
+  real, pointer :: xp, yp(:), zp(:,:,:)
+
+  allocate(x, y(2:5), z(0:1,-1:1,1:4))
+  allocate(xp, yp(2:5), zp(0:1,-1:1,1:4))
+
+
+  call foo_1(x)
+  if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count
+  call foo_1(y)
+  if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count
+  call foo_1(z)
+  if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count
+  call foo_2(x)
+  if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count
+  call foo_2(y)
+  if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count
+  call foo_2(z)
+  if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count
+  call foo_3(xp)
+  if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count
+  call foo_3(yp)
+  if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count
+  call foo_3(zp)
+  if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count
+
+  if (error_count == 0) then
+    write(*,*) 'OK'
+  else
+    stop 1
+  end if
+
+  deallocate(x, y, z)
+  deallocate(xp, yp, zp)
+end program ass_rank_inquiry